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
72 =head2 get_label_options;
74 $options = get_label_options()
76 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
80 sub get_label_options {
81 my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout
82 my $sth = C4::Context->dbh->prepare($query2);
84 return $sth->fetchrow_hashref;
88 my $dbh = C4::Context->dbh;
90 my $query = " Select * from labels_conf";
91 my $sth = $dbh->prepare($query);
94 while ( my $data = $sth->fetchrow_hashref ) {
96 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
97 push( @resultsloop, $data );
104 my ($layout_id) = @_;
105 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;
116 sub get_active_layout {
117 my $query = " Select * from labels_conf where active = 1"; # FIXME: exact same as get_label_options
118 my $sth = C4::Context->dbh->prepare($query);
120 return $sth->fetchrow_hashref;
124 my ($layout_id) = @_;
125 my $dbh = C4::Context->dbh;
127 # get the actual items to be printed.
128 my $query = "delete from labels_conf where id = ?";
129 my $sth = $dbh->prepare($query);
130 $sth->execute($layout_id);
134 sub get_printingtypes {
135 my ($layout_id) = @_;
137 # FIXME hard coded print types
138 push( @printtypes, { code => 'BAR', desc => "barcode only" } );
139 push( @printtypes, { code => 'BIB', desc => "biblio only" } );
140 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
141 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
142 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
143 push( @printtypes, { code => 'CSV', desc => "csv output" } );
144 push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
146 my $conf = get_layout($layout_id);
147 my $active_printtype = $conf->{'printingtype'};
149 # lop thru layout, insert selected to hash
151 foreach my $printtype (@printtypes) {
152 if ( $printtype->{'code'} eq $active_printtype ) {
153 $printtype->{'active'} = 1;
159 # this sub (build_text_dropbox) is deprecated and should be deleted.
162 sub build_text_dropbox {
164 my $field_count = 7; # <----------- FIXME hard coded
167 ? push( @lines, { num => '', selected => '1' } )
168 : push( @lines, { num => '' } );
169 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
170 my $line = { num => "$i" };
171 $line->{'selected'} = 1 if $i eq $order;
172 push( @lines, $line );
177 sub get_text_fields {
178 my ( $layout_id, $sorttype ) = @_;
181 my $sortorder = get_layout($layout_id);
182 if ( $sortorder->{formatstring} ) {
184 return $sortorder->{formatstring};
187 my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } );
188 my $line = $sortorder->{formatstring};
189 my $status = $csv->parse($line);
191 map { { 'code' => $_, desc => $_ } } $csv->fields();
192 $error = $csv->error_input();
193 warn $error if $error; # TODO - do more with this.
198 # These fields are hardcoded based on the template for label-edit-layout.pl
203 order => $sortorder->{'itemtype'}
208 order => $sortorder->{'issn'}
213 order => $sortorder->{'isbn'}
218 order => $sortorder->{'barcode'}
223 order => $sortorder->{'author'}
228 order => $sortorder->{'title'}
231 code => 'itemcallnumber',
232 desc => "Call Number",
233 order => $sortorder->{'itemcallnumber'}
238 foreach my $field (@text_fields) {
239 push( @new_fields, $field ) if $field->{'order'} > 0;
242 @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
245 # if we have a 'formatstring', then we ignore these hardcoded fields.
248 if ( $sorttype eq 'codes' )
249 { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit
250 return @sorted_fields;
253 foreach my $field (@sorted_fields) {
254 $active_fields .= "$field->{'desc'} ";
256 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.
274 sub add_batch ($;$) {
275 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
276 my $batch_list = (@_) ? shift : undef;
277 my $dbh = C4::Context->dbh;
278 # FIXME : batch_id should be an auto_incr INT. Temporarily casting as int ( see koha bug 2555 )
279 # until a label_batches table is added, and we can convert batch_id to int.
280 my $q ="SELECT MAX( CAST(batch_id AS SIGNED) ) FROM $table";
281 my $sth = $dbh->prepare($q);
283 my ($batch_id) = $sth->fetchrow_array || 0;
286 if ($table eq 'patroncards') {
287 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`borrowernumber`) VALUES (?,?)");
289 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`itemnumber` ) VALUES (?,?)");
292 $sth->execute($batch_id,$_);
298 #FIXME: Needs to be ported to receive $batch_type
299 # ... this looks eerily like add_batch() ...
300 sub get_highest_batch {
301 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
303 "select distinct batch_id from $table order by batch_id desc limit 1";
304 my $sth = C4::Context->dbh->prepare($q);
306 my $data = $sth->fetchrow_hashref or return 1;
307 return ($data->{'batch_id'} || 1);
311 sub get_batches (;$) {
312 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
313 my $q = "SELECT batch_id, COUNT(*) AS num FROM $table GROUP BY batch_id";
314 my $sth = C4::Context->dbh->prepare($q);
316 my $batches = $sth->fetchall_arrayref({});
321 my ($batch_id, $batch_type) = @_;
322 warn "Deleteing batch of type $batch_type";
323 my $dbh = C4::Context->dbh;
324 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
325 my $sth = $dbh->prepare($q);
326 $sth->execute($batch_id);
330 sub get_barcode_types {
331 my ($layout_id) = @_;
332 my $layout = get_layout($layout_id);
333 my $barcode = $layout->{'barcodetype'};
336 push( @array, { code => 'CODE39', desc => 'Code 39' } );
337 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
338 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
339 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
341 foreach my $line (@array) {
342 if ( $line->{'code'} eq $barcode ) {
343 $line->{'active'} = 1;
354 $unitvalue = '1' if ( $units eq 'POINT' );
355 $unitvalue = '2.83464567' if ( $units eq 'MM' );
356 $unitvalue = '28.3464567' if ( $units eq 'CM' );
357 $unitvalue = 72 if ( $units eq 'INCH' );
361 sub GetTextWrapCols {
362 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
366 # my $textlimit = $label_width - ($left_text_margin);
367 my $textlimit = $label_width - ( 3 * $left_text_margin);
369 while ( $strwidth < $textlimit ) {
370 $strwidth = prStrWidth( $string, $font, $fontsize );
371 $string = $string . '0';
372 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
378 sub GetActiveLabelTemplate {
379 my $dbh = C4::Context->dbh;
380 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
381 my $sth = $dbh->prepare($query);
383 my $active_tmpl = $sth->fetchrow_hashref;
388 sub GetSingleLabelTemplate {
390 my $dbh = C4::Context->dbh;
391 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
392 my $sth = $dbh->prepare($query);
393 $sth->execute($tmpl_id);
394 my $template = $sth->fetchrow_hashref;
399 sub SetActiveTemplate {
403 my $dbh = C4::Context->dbh;
404 my $query = " UPDATE labels_templates SET active = NULL";
405 my $sth = $dbh->prepare($query);
408 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
409 $sth = $dbh->prepare($query);
410 $sth->execute($tmpl_id);
414 sub set_active_layout {
416 my ($layout_id) = @_;
417 my $dbh = C4::Context->dbh;
418 my $query = " UPDATE labels_conf SET active = NULL";
419 my $sth = $dbh->prepare($query);
422 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
423 $sth = $dbh->prepare($query);
424 $sth->execute($layout_id);
430 my $dbh = C4::Context->dbh;
431 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
432 my $sth = $dbh->prepare($query);
433 $sth->execute($tmpl_id);
439 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
440 $page_height, $label_width, $label_height, $topmargin,
441 $leftmargin, $cols, $rows, $colgap,
442 $rowgap, $font, $fontsize, $units
444 $debug and warn "Passed \$font:$font";
445 my $dbh = C4::Context->dbh;
447 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
448 page_height=?, label_width=?, label_height=?, topmargin=?,
449 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
453 my $sth = $dbh->prepare($query);
455 $tmpl_code, $tmpl_desc, $page_width, $page_height,
456 $label_width, $label_height, $topmargin, $leftmargin,
457 $cols, $rows, $colgap, $rowgap,
458 $font, $fontsize, $units, $tmpl_id
460 my $dberror = $sth->errstr;
468 $tmpl_code, $tmpl_desc, $page_width, $page_height,
469 $label_width, $label_height, $topmargin, $leftmargin,
470 $cols, $rows, $colgap, $rowgap,
471 $font, $fontsize, $units
474 my $dbh = C4::Context->dbh;
476 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
477 page_height, label_width, label_height, topmargin,
478 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
479 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
481 my $sth = $dbh->prepare($query);
483 $tmpl_code, $tmpl_desc, $page_width, $page_height,
484 $label_width, $label_height, $topmargin, $leftmargin,
485 $cols, $rows, $colgap, $rowgap,
486 $font, $fontsize, $units
488 my $dberror = $sth->errstr;
493 sub GetAllLabelTemplates {
494 my $dbh = C4::Context->dbh;
496 # get the actual items to be printed.
498 my $query = " Select * from labels_templates ";
499 my $sth = $dbh->prepare($query);
502 while ( my $data = $sth->fetchrow_hashref ) {
503 push( @resultsloop, $data );
507 #warn Dumper @resultsloop;
515 $barcodetype, $title, $subtitle, $isbn, $issn,
516 $itemtype, $bcn, $text_justify, $callnum_split,
517 $itemcallnumber, $author, $tmpl_id,
518 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
521 my $dbh = C4::Context->dbh;
522 my $query2 = "update labels_conf set active = NULL";
523 my $sth2 = $dbh->prepare($query2);
525 $query2 = "INSERT INTO labels_conf
526 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
527 text_justify, callnum_split, itemcallnumber, author, printingtype,
528 guidebox, startlabel, layoutname, formatstring, active )
529 values ( ?, ?,?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?,?,?, 1 )";
530 $sth2 = $dbh->prepare($query2);
532 $barcodetype, $title, $subtitle, $isbn, $issn,
534 $itemtype, $bcn, $text_justify, $callnum_split,
535 $itemcallnumber, $author, $printingtype,
536 $guidebox, $startlabel, $layoutname, $formatstring
540 SetActiveTemplate($tmpl_id);
547 $barcodetype, $title, $subtitle, $isbn, $issn,
548 $itemtype, $bcn, $text_justify, $callnum_split,
549 $itemcallnumber, $author, $tmpl_id,
550 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
556 my $dbh = C4::Context->dbh;
557 my $query2 = "update labels_conf set
558 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
559 itemtype=?, barcode=?, text_justify=?, callnum_split=?,
560 itemcallnumber=?, author=?, printingtype=?,
561 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
562 my $sth2 = $dbh->prepare($query2);
564 $barcodetype, $title, $subtitle, $isbn, $issn,
565 $itemtype, $bcn, $text_justify, $callnum_split,
566 $itemcallnumber, $author, $printingtype,
567 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
574 =head2 GetAllPrinterProfiles;
576 @profiles = GetAllPrinterProfiles()
578 Returns an array of references-to-hash, whos keys are .....
582 sub GetAllPrinterProfiles {
584 my $dbh = C4::Context->dbh;
586 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
587 my $sth = $dbh->prepare($query);
590 while ( my $data = $sth->fetchrow_hashref ) {
591 push( @resultsloop, $data );
598 =head2 GetSinglePrinterProfile;
600 $profile = GetSinglePrinterProfile()
602 Returns a hashref whos keys are...
606 sub GetSinglePrinterProfile {
608 my $dbh = C4::Context->dbh;
609 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
610 my $sth = $dbh->prepare($query);
611 $sth->execute($prof_id);
612 my $template = $sth->fetchrow_hashref;
619 SaveProfile('parameters')
621 When passed a set of parameters, this function updates the given profile with the new parameters.
627 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
629 my $dbh = C4::Context->dbh;
631 " UPDATE printers_profile
632 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
634 my $sth = $dbh->prepare($query);
636 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
641 =head2 CreateProfile;
643 CreateProfile('parameters')
645 When passed a set of parameters, this function creates a new profile containing those parameters
646 and returns any errors.
652 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
653 $offset_vert, $creep_horz, $creep_vert, $units
655 my $dbh = C4::Context->dbh;
657 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
658 offset_horz, offset_vert, creep_horz, creep_vert, unit)
659 VALUES(?,?,?,?,?,?,?,?,?) ";
660 my $sth = $dbh->prepare($query);
662 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
663 $offset_vert, $creep_horz, $creep_vert, $units
665 my $error = $sth->errstr;
670 =head2 DeleteProfile;
672 DeleteProfile(prof_id)
674 When passed a profile id, this function deletes that profile from the database and returns any errors.
680 my $dbh = C4::Context->dbh;
681 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
682 my $sth = $dbh->prepare($query);
683 $sth->execute($prof_id);
684 my $error = $sth->errstr;
689 =head2 GetAssociatedProfile;
691 $assoc_prof = GetAssociatedProfile(tmpl_id)
693 When passed a template id, this function returns the parameters from the currently associated printer profile
694 in a hashref where key=fieldname and value=fieldvalue.
698 sub GetAssociatedProfile {
700 my $dbh = C4::Context->dbh;
701 # First we find out the prof_id for the associated profile...
702 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
703 my $sth = $dbh->prepare($query);
704 $sth->execute($tmpl_id);
705 my $assoc_prof = $sth->fetchrow_hashref;
707 # Then we retrieve that profile and return it to the caller...
708 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
712 =head2 SetAssociatedProfile;
714 SetAssociatedProfile($prof_id, $tmpl_id)
716 When passed both a profile id and template id, this function establishes an association between the two. No more
717 than one profile may be associated with any given template at the same time.
721 sub SetAssociatedProfile {
723 my ($prof_id, $tmpl_id) = @_;
725 my $dbh = C4::Context->dbh;
726 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
727 my $sth = $dbh->prepare($query);
728 $sth->execute($prof_id, $tmpl_id, $prof_id);
733 =head2 GetLabelItems;
735 $options = GetLabelItems()
737 Returns an array of references-to-hash, whos keys are the fields from the biblio, biblioitems, items and labels tables in the Koha database.
743 my $dbh = C4::Context->dbh;
745 my @resultsloop = ();
756 $sth = $dbh->prepare($query3);
757 $sth->execute($batch_id);
763 $sth = $dbh->prepare($query3);
766 my $cnt = $sth->rows;
768 while ( my $data = $sth->fetchrow_hashref ) {
770 # lets get some summary info from each item
772 # FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten.
773 # Something like this, perhaps, but this also causes problems because we need more fields sometimes.
774 # SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
775 "SELECT bi.*, i.*, b.*
776 FROM items AS i, biblioitems AS bi ,biblio AS b
777 WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber";
778 my $sth1 = $dbh->prepare($query1);
779 $sth1->execute( $data->{'itemnumber'} );
781 my $data1 = $sth1->fetchrow_hashref();
782 $data1->{'labelno'} = $i1;
783 $data1->{'labelid'} = $data->{'labelid'};
784 $data1->{'batch_id'} = $batch_id;
785 $data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
787 push( @resultsloop, $data1 );
807 =head2 GetBarcodeData
811 Parse labels_conf.formatstring value
812 (one value of the csv, which has already been split)
813 and return string from koha tables or MARC record.
820 my ( $f, $item, $record ) = @_;
821 my $kohatables = &_descKohaTables();
823 my $match_kohatable = join(
826 @{ $kohatables->{biblio} },
827 @{ $kohatables->{biblioitems} },
828 @{ $kohatables->{items} }
833 if ( $f =~ /^'(.*)'.*/ ) {
834 # single quotes indicate a static text string.
838 elsif ( $f =~ /^($match_kohatable).*/ ) {
839 $datastring .= $item->{$f};
842 elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
843 my ($field,$subf,$ws) = ($1,$2,$3);
845 my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
846 my @marcfield = $record->field($field);
848 if($field eq $itemtag) { # item-level data, we need to get the right item.
849 foreach my $itemfield (@marcfield) {
850 if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
851 $datastring .= $itemfield->subfield($subf ) . $ws;
855 } else { # bib-level data, we'll take the first matching tag/subfield.
856 $datastring .= $marcfield[0]->subfield($subf) . $ws ;
862 warn "failed to parse label formatstring: $f";
863 last; # Failed to match
869 =head2 descKohaTables
871 Return a hashref of an array of hashes,
876 sub _descKohaTables {
877 my $dbh = C4::Context->dbh();
879 for my $table ( 'biblio','biblioitems','items' ) {
880 my $sth = $dbh->column_info(undef,undef,$table,'%');
881 while (my $info = $sth->fetchrow_hashref()){
882 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
889 sub GetPatronCardItems {
891 my ( $batch_id ) = @_;
894 my $dbh = C4::Context->dbh;
895 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
896 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
897 my $sth = $dbh->prepare($query);
898 $sth->execute($batch_id);
900 while ( my $data = $sth->fetchrow_hashref ) {
901 my $patron_data = GetMember( $data->{'borrowernumber'} );
902 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
903 $patron_data->{'cardno'} = $cardno;
904 $patron_data->{'cardid'} = $data->{'cardid'};
905 $patron_data->{'batch_id'} = $batch_id;
906 push( @resultsloop, $patron_data );
914 sub deduplicate_batch {
915 my ( $batch_id, $batch_type ) = @_;
918 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
919 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
922 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
926 my $sth = C4::Context->dbh->prepare($query);
927 $sth->execute($batch_id);
928 warn $sth->errstr if $sth->errstr;
929 $sth->rows or return undef, $sth->errstr;
935 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
936 ORDER BY timestamp ASC
939 while (my $data = $sth->fetchrow_hashref()) {
940 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
941 my $limit = $data->{count} - 1 or next;
942 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
943 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
944 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
945 $sth2->execute($batch_id, $itemnumber) and
946 $killed += ($data->{count} - 1);
947 warn $sth2->errstr if $sth2->errstr;
949 return $killed, undef;
952 our $possible_decimal = qr/\d+(?:\.\d+)?/;
957 # lccn examples: 'HE8700.7 .P6T44 1983', 'BS2545.E8 H39 1996';
959 ^([a-zA-Z]+) # HE # BS
960 (\d+(?:\.\d)*) # 8700.7 # 2545
962 (\.*\D+\d*) # .P6 # .E8
964 (.*) # T44 1983 # H39 1996 # everything else (except any bracketing spaces)
967 unless (scalar @parts) {
968 $debug and print STDERR "split_lccn regexp failed to match string: $_\n";
969 push @parts, $_; # if no match, just push the whole string.
971 push @parts, split /\s+/, pop @parts; # split the last piece into an arbitrary number of pieces at spaces
972 $debug and print STDERR "split_lccn array: ", join(" | ", @parts), "\n";
979 s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
980 # ddcn examples: 'R220.3 H2793Z H32 c.2', 'BIO JP2 R5c.1'
983 ^([a-zA-Z-]+[0-9]?-?[a-zA-Z]*(?:$possible_decimal)?) # R220.3 # BIO # first example will require extra splitting
985 (.+) # H2793Z H32 c.2 # R5c.1 # everything else (except bracketing spaces)
988 unless (scalar @parts) {
989 $debug and print STDERR "split_ddcn regexp failed to match string: $_\n";
990 push @parts, $_; # if no match, just push the whole string.
993 if ($parts[ 0] =~ /^([a-zA-Z]+)($possible_decimal)$/) {
994 shift @parts; # pull off the mathching first element, like example 1
995 unshift @parts, $1, $2; # replace it with the two pieces
998 push @parts, split /\s+/, pop @parts; # split the last piece into an arbitrary number of pieces at spaces
1000 if ($parts[-1] !~ /^.*\d-\d.*$/ && $parts[-1] =~ /^(.*\d+)(\D.*)$/) {
1001 pop @parts; # pull off the mathching last element, like example 2
1002 push @parts, $1, $2; # replace it with the two pieces
1005 $debug and print STDERR "split_ddcn array: ", join(" | ", @parts), "\n";
1012 # Split fiction call numbers based on spaces
1015 if ($fcn =~ m/([A-Za-z0-9]+\.?[0-9]?)(\W?).*?/x) {
1016 push (@fcn_split, $1);
1020 last SPLIT_FCN; # No match, break out of the loop
1028 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1029 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
1031 # Replaced item's itemtype with the more user-friendly description...
1032 my $dbh = C4::Context->dbh;
1033 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
1035 while ( my $data = $sth->fetchrow_hashref ) {
1036 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
1037 $$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
1042 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
1043 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.).
1045 my $layout_id = $$conf_data->{'id'};
1047 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1049 my @str_fields = get_text_fields($layout_id, 'codes' );
1050 my $record = GetMarcBiblio($$item->{biblionumber});
1051 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1052 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1054 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1056 # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
1057 my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
1058 for my $field (@str_fields) {
1059 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1060 if ($field->{'code'} eq 'itemtype') {
1061 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1063 elsif ($$conf_data->{'formatstring'}) {
1064 # if labels_conf.formatstring has a value, then it overrides the hardcoded option.
1065 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1068 $field->{data} = $$item->{$field->{'code'}} ;
1070 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1071 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1072 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1073 my $font = prFont($fontname);
1074 # if the display option for this field is selected in the DB,
1075 # and the item record has some values for this field, display it.
1076 # Or if there is a csv list of fields to display, display them.
1077 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1079 my $str = $field->{data} ;
1080 # strip out naughty existing nl/cr's
1084 my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? )
1085 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
1086 if ($cn_source eq 'lcc') {
1087 @strings = split_lccn($str);
1088 @strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number
1089 push (@strings, $str) if !@strings; # If it was not that, send it on unsplit
1090 } elsif ($cn_source eq 'ddc') {
1091 @strings = split_ddcn($str);
1092 @strings = split_fcn($str) if !@strings;
1093 push (@strings, $str) if !@strings;
1095 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1096 push @strings, $str;
1099 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1100 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1101 $str =~ s/\)/\\\)/g;
1102 # Wrap text lines exceeding $text_wrap_cols length...
1103 $Text::Wrap::columns = $text_wrap_cols;
1104 my @line = split(/\n/ ,wrap('', '', $str));
1105 # If this is a title field, limit to two lines; all others limit to one...
1106 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1107 while (scalar(@line) > 2) {
1111 while (scalar(@line) > 1) {
1115 push(@strings, @line);
1117 # loop for each string line
1118 foreach my $str (@strings) {
1121 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1122 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1123 $hPos = $x_pos + $label_width - ( $left_text_margin + $stringwidth );
1124 } elsif($$conf_data->{'text_justify'} eq 'C') {
1125 # some code to try and center each line on the label based on font size and string point width...
1126 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1127 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1128 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1130 $hPos = ( $x_pos + $left_text_margin );
1132 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1133 $vPos = $vPos - $line_spacer;
1140 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1141 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1145 sub DrawPatronCardText {
1147 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1148 $text_wrap_cols, $text, $printingtype )
1151 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1153 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1154 my $font = prFont($fontname);
1158 foreach my $line (keys %$text) {
1159 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1160 # some code to try and center each line on the label based on font size and string point width...
1161 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1162 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1163 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1165 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1166 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.).
1167 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1171 # Not used anywhere.
1175 # my ($fontsize) = @_;
1177 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1183 # x and y are from the top-left :)
1184 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1185 my $num_of_bars = length($barcode);
1186 my $bar_width = $width * .8; # %80 of length of label width
1187 my $tot_bar_length = 0;
1189 my $guard_length = 10;
1190 my $xsize_ratio = 0;
1192 if ( $barcodetype eq 'CODE39' ) {
1193 $bar_length = '17.5';
1195 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1196 $xsize_ratio = ( $bar_width / $tot_bar_length );
1198 PDF::Reuse::Barcode::Code39(
1199 x => ( $x_pos + ( $width / 10 ) ),
1200 y => ( $y_pos + ( $height / 10 ) ),
1201 value => "*$barcode*",
1202 ySize => ( .02 * $height ),
1203 xSize => $xsize_ratio,
1205 mode => 'graphic', # the only other option here is Type3...
1209 warn "$barcodetype, $barcode FAILED:$@";
1213 elsif ( $barcodetype eq 'CODE39MOD' ) {
1215 # get modulo43 checksum
1216 my $c39 = CheckDigits('code_39');
1217 $barcode = $c39->complete($barcode);
1221 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1222 $xsize_ratio = ( $bar_width / $tot_bar_length );
1224 PDF::Reuse::Barcode::Code39(
1225 x => ( $x_pos + ( $width / 10 ) ),
1226 y => ( $y_pos + ( $height / 10 ) ),
1227 value => "*$barcode*",
1228 ySize => ( .02 * $height ),
1229 xSize => $xsize_ratio,
1231 mode => 'graphic', # the only other option here is Type3...
1236 warn "$barcodetype, $barcode FAILED:$@";
1239 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1241 # get modulo43 checksum
1242 my $c39_10 = CheckDigits('visa');
1243 $barcode = $c39_10->complete($barcode);
1247 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1248 $xsize_ratio = ( $bar_width / $tot_bar_length );
1250 PDF::Reuse::Barcode::Code39(
1251 x => ( $x_pos + ( $width / 10 ) ),
1252 y => ( $y_pos + ( $height / 10 ) ),
1253 value => "*$barcode*",
1254 ySize => ( .02 * $height ),
1255 xSize => $xsize_ratio,
1258 mode => 'graphic', # the only other option here is Type3...
1263 warn "$barcodetype, $barcode FAILED:$@";
1268 elsif ( $barcodetype eq 'COOP2OF5' ) {
1269 $bar_length = '9.43333333333333';
1271 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1272 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1274 PDF::Reuse::Barcode::COOP2of5(
1275 x => ( $x_pos + ( $width / 10 ) ),
1276 y => ( $y_pos + ( $height / 10 ) ),
1278 ySize => ( .02 * $height ),
1279 xSize => $xsize_ratio,
1283 warn "$barcodetype, $barcode FAILED:$@";
1287 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1288 $bar_length = '13.1333333333333';
1290 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1291 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1293 PDF::Reuse::Barcode::Industrial2of5(
1294 x => ( $x_pos + ( $width / 10 ) ),
1295 y => ( $y_pos + ( $height / 10 ) ),
1297 ySize => ( .02 * $height ),
1298 xSize => $xsize_ratio,
1302 warn "$barcodetype, $barcode FAILED:$@";
1306 my $moo2 = $tot_bar_length * $xsize_ratio;
1308 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1309 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1312 =head2 build_circ_barcode;
1314 build_circ_barcode( $x_pos, $y_pos, $barcode,
1315 $barcodetype, \$item);
1317 $item is the result of a previous call to GetLabelItems();
1322 sub build_circ_barcode {
1323 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1325 #warn Dumper \$item;
1327 #warn "value = $value\n";
1331 if ( $barcodetype eq 'EAN13' ) {
1333 #testing EAN13 barcodes hack
1334 $value = $value . '000000000';
1336 $value = substr( $value, 0, 12 );
1340 PDF::Reuse::Barcode::EAN13(
1341 x => ( $x_pos_circ + 27 ),
1342 y => ( $y_pos + 15 ),
1350 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1351 # i think its embedding extra fonts in the pdf file.
1352 # mode => 'graphic',
1356 $item->{'barcodeerror'} = 1;
1358 #warn "EAN13BARCODE FAILED:$@";
1364 elsif ( $barcodetype eq 'Code39' ) {
1367 PDF::Reuse::Barcode::Code39(
1368 x => ( $x_pos_circ + 9 ),
1369 y => ( $y_pos + 15 ),
1376 mode => 'graphic', # the only other option here is Type3...
1380 $item->{'barcodeerror'} = 1;
1382 #warn "CODE39BARCODE $value FAILED:$@";
1389 elsif ( $barcodetype eq 'Matrix2of5' ) {
1391 #warn "MATRIX ELSE:";
1393 #testing MATRIX25 barcodes hack
1394 # $value = $value.'000000000';
1397 # $value = substr( $value, 0, 12 );
1401 PDF::Reuse::Barcode::Matrix2of5(
1402 x => ( $x_pos_circ + 27 ),
1403 y => ( $y_pos + 15 ),
1413 $item->{'barcodeerror'} = 1;
1415 #warn "BARCODE FAILED:$@";
1422 elsif ( $barcodetype eq 'EAN8' ) {
1424 #testing ean8 barcodes hack
1425 $value = $value . '000000000';
1427 $value = substr( $value, 0, 8 );
1431 #warn "EAN8 ELSEIF";
1433 PDF::Reuse::Barcode::EAN8(
1434 x => ( $x_pos_circ + 42 ),
1435 y => ( $y_pos + 15 ),
1445 $item->{'barcodeerror'} = 1;
1447 #warn "BARCODE FAILED:$@";
1454 elsif ( $barcodetype eq 'UPC-E' ) {
1456 PDF::Reuse::Barcode::UPCE(
1457 x => ( $x_pos_circ + 27 ),
1458 y => ( $y_pos + 15 ),
1468 $item->{'barcodeerror'} = 1;
1470 #warn "BARCODE FAILED:$@";
1476 elsif ( $barcodetype eq 'NW7' ) {
1478 PDF::Reuse::Barcode::NW7(
1479 x => ( $x_pos_circ + 27 ),
1480 y => ( $y_pos + 15 ),
1490 $item->{'barcodeerror'} = 1;
1492 #warn "BARCODE FAILED:$@";
1498 elsif ( $barcodetype eq 'ITF' ) {
1500 PDF::Reuse::Barcode::ITF(
1501 x => ( $x_pos_circ + 27 ),
1502 y => ( $y_pos + 15 ),
1512 $item->{'barcodeerror'} = 1;
1514 #warn "BARCODE FAILED:$@";
1520 elsif ( $barcodetype eq 'Industrial2of5' ) {
1522 PDF::Reuse::Barcode::Industrial2of5(
1523 x => ( $x_pos_circ + 27 ),
1524 y => ( $y_pos + 15 ),
1533 $item->{'barcodeerror'} = 1;
1535 #warn "BARCODE FAILED:$@";
1541 elsif ( $barcodetype eq 'IATA2of5' ) {
1543 PDF::Reuse::Barcode::IATA2of5(
1544 x => ( $x_pos_circ + 27 ),
1545 y => ( $y_pos + 15 ),
1554 $item->{'barcodeerror'} = 1;
1556 #warn "BARCODE FAILED:$@";
1563 elsif ( $barcodetype eq 'COOP2of5' ) {
1565 PDF::Reuse::Barcode::COOP2of5(
1566 x => ( $x_pos_circ + 27 ),
1567 y => ( $y_pos + 15 ),
1576 $item->{'barcodeerror'} = 1;
1578 #warn "BARCODE FAILED:$@";
1584 elsif ( $barcodetype eq 'UPC-A' ) {
1587 PDF::Reuse::Barcode::UPCA(
1588 x => ( $x_pos_circ + 27 ),
1589 y => ( $y_pos + 15 ),
1598 $item->{'barcodeerror'} = 1;
1600 #warn "BARCODE FAILED:$@";
1609 =head2 draw_boundaries
1611 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1612 $y_pos, $spine_width, $label_height, $circ_width)
1614 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1619 sub draw_boundaries {
1622 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1623 $spine_width, $label_height, $circ_width
1626 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1627 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1630 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1632 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1634 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1635 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1636 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1638 $y_pos = ( $y_pos - $label_height );
1645 sub drawbox { $lower_left_x, $lower_left_y,
1646 $upper_right_x, $upper_right_y )
1648 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1650 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1652 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1658 my ( $llx, $lly, $urx, $ury ) = @_;
1660 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1662 my $str = "q\n"; # save the graphic state
1663 $str .= "0.5 w\n"; # border color red
1664 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1665 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1666 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1668 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1669 $str .= "B\n"; # fill (and a little more)
1670 $str .= "Q\n"; # save the graphic state
1676 END { } # module clean-up code here (global destructor)
1683 Mason James <mason@katipo.co.nz>