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;
954 my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
956 # lccn example 'HE8700.7 .P6T44 1983';
959 ([0-9]+\.*[0-9]*) # 8700.7
961 (\.*[a-zA-Z0-9]*) # P6T44
966 # strip something occuring spaces too
967 $splits[0] =~ s/\s+$//;
968 $splits[1] =~ s/\s+$//;
969 $splits[2] =~ s/\s+$//;
976 $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
978 # ddcn example R220.3 H2793Z H32 c.2
979 my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
980 ([0-9]+\.[0-9]*) # 220.3
981 \s? # space (not requiring anything beyond the call number)
982 ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
983 \s? # space if it exists
984 ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
985 \s? # space if ie exists
986 ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
994 # Split fiction call numbers based on spaces
997 if ($fcn =~ m/([A-Za-z0-9]+)(\W?).*?/x) {
998 push (@fcn_split, $1);
1002 last SPLIT_FCN; # No match, break out of the loop
1010 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1011 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
1013 # Replaced item's itemtype with the more user-friendly description...
1014 my $dbh = C4::Context->dbh;
1015 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
1017 while ( my $data = $sth->fetchrow_hashref ) {
1018 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
1019 $$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
1024 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
1025 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.).
1027 my $layout_id = $$conf_data->{'id'};
1029 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1031 my @str_fields = get_text_fields($layout_id, 'codes' );
1032 my $record = GetMarcBiblio($$item->{biblionumber});
1033 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1034 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1036 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1038 # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
1039 my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
1040 for my $field (@str_fields) {
1041 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1042 if ($field->{'code'} eq 'itemtype') {
1043 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1045 elsif ($$conf_data->{'formatstring'}) {
1046 # if labels_conf.formatstring has a value, then it overrides the hardcoded option.
1047 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1050 $field->{data} = $$item->{$field->{'code'}} ;
1052 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1053 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1054 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1055 my $font = prFont($fontname);
1056 # if the display option for this field is selected in the DB,
1057 # and the item record has some values for this field, display it.
1058 # Or if there is a csv list of fields to display, display them.
1059 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1061 my $str = $field->{data} ;
1062 # strip out naughty existing nl/cr's
1066 my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? )
1067 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
1068 if ($cn_source eq 'lcc') {
1069 @strings = split_lccn($str);
1070 @strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number
1071 push (@strings, $str) if !@strings; # If it was not that, send it on unsplit
1072 } elsif ($cn_source eq 'ddc') {
1073 @strings = split_ddcn($str);
1074 @strings = split_fcn($str) if !@strings;
1075 push (@strings, $str) if !@strings;
1077 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1078 push @strings, $str;
1081 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1082 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1083 $str =~ s/\)/\\\)/g;
1084 # Wrap text lines exceeding $text_wrap_cols length...
1085 $Text::Wrap::columns = $text_wrap_cols;
1086 my @line = split(/\n/ ,wrap('', '', $str));
1087 # If this is a title field, limit to two lines; all others limit to one...
1088 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1089 while (scalar(@line) > 2) {
1093 while (scalar(@line) > 1) {
1097 push(@strings, @line);
1099 # loop for each string line
1100 foreach my $str (@strings) {
1102 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1103 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1104 $hPos = $x_pos + $label_width - ( $left_text_margin + $stringwidth );
1105 } elsif($$conf_data->{'text_justify'} eq 'C') {
1106 # some code to try and center each line on the label based on font size and string point width...
1107 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1108 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1109 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1111 $hPos = ( $x_pos + $left_text_margin );
1113 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1114 $vPos = $vPos - $line_spacer;
1121 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1122 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1126 sub DrawPatronCardText {
1128 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1129 $text_wrap_cols, $text, $printingtype )
1132 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1134 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1135 my $font = prFont($fontname);
1139 foreach my $line (keys %$text) {
1140 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1141 # some code to try and center each line on the label based on font size and string point width...
1142 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1143 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1144 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1146 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1147 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.).
1148 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1152 # Not used anywhere.
1156 # my ($fontsize) = @_;
1158 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1164 # x and y are from the top-left :)
1165 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1166 my $num_of_bars = length($barcode);
1167 my $bar_width = $width * .8; # %80 of length of label width
1168 my $tot_bar_length = 0;
1170 my $guard_length = 10;
1171 my $xsize_ratio = 0;
1173 if ( $barcodetype eq 'CODE39' ) {
1174 $bar_length = '17.5';
1176 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1177 $xsize_ratio = ( $bar_width / $tot_bar_length );
1179 PDF::Reuse::Barcode::Code39(
1180 x => ( $x_pos + ( $width / 10 ) ),
1181 y => ( $y_pos + ( $height / 10 ) ),
1182 value => "*$barcode*",
1183 ySize => ( .02 * $height ),
1184 xSize => $xsize_ratio,
1189 warn "$barcodetype, $barcode FAILED:$@";
1193 elsif ( $barcodetype eq 'CODE39MOD' ) {
1195 # get modulo43 checksum
1196 my $c39 = CheckDigits('code_39');
1197 $barcode = $c39->complete($barcode);
1201 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1202 $xsize_ratio = ( $bar_width / $tot_bar_length );
1204 PDF::Reuse::Barcode::Code39(
1205 x => ( $x_pos + ( $width / 10 ) ),
1206 y => ( $y_pos + ( $height / 10 ) ),
1207 value => "*$barcode*",
1208 ySize => ( .02 * $height ),
1209 xSize => $xsize_ratio,
1215 warn "$barcodetype, $barcode FAILED:$@";
1218 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1220 # get modulo43 checksum
1221 my $c39_10 = CheckDigits('visa');
1222 $barcode = $c39_10->complete($barcode);
1226 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1227 $xsize_ratio = ( $bar_width / $tot_bar_length );
1229 PDF::Reuse::Barcode::Code39(
1230 x => ( $x_pos + ( $width / 10 ) ),
1231 y => ( $y_pos + ( $height / 10 ) ),
1232 value => "*$barcode*",
1233 ySize => ( .02 * $height ),
1234 xSize => $xsize_ratio,
1241 warn "$barcodetype, $barcode FAILED:$@";
1246 elsif ( $barcodetype eq 'COOP2OF5' ) {
1247 $bar_length = '9.43333333333333';
1249 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1250 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1252 PDF::Reuse::Barcode::COOP2of5(
1253 x => ( $x_pos + ( $width / 10 ) ),
1254 y => ( $y_pos + ( $height / 10 ) ),
1256 ySize => ( .02 * $height ),
1257 xSize => $xsize_ratio,
1261 warn "$barcodetype, $barcode FAILED:$@";
1265 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1266 $bar_length = '13.1333333333333';
1268 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1269 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1271 PDF::Reuse::Barcode::Industrial2of5(
1272 x => ( $x_pos + ( $width / 10 ) ),
1273 y => ( $y_pos + ( $height / 10 ) ),
1275 ySize => ( .02 * $height ),
1276 xSize => $xsize_ratio,
1280 warn "$barcodetype, $barcode FAILED:$@";
1284 my $moo2 = $tot_bar_length * $xsize_ratio;
1286 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1287 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1290 =head2 build_circ_barcode;
1292 build_circ_barcode( $x_pos, $y_pos, $barcode,
1293 $barcodetype, \$item);
1295 $item is the result of a previous call to GetLabelItems();
1300 sub build_circ_barcode {
1301 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1303 #warn Dumper \$item;
1305 #warn "value = $value\n";
1309 if ( $barcodetype eq 'EAN13' ) {
1311 #testing EAN13 barcodes hack
1312 $value = $value . '000000000';
1314 $value = substr( $value, 0, 12 );
1318 PDF::Reuse::Barcode::EAN13(
1319 x => ( $x_pos_circ + 27 ),
1320 y => ( $y_pos + 15 ),
1328 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1329 # i think its embedding extra fonts in the pdf file.
1330 # mode => 'graphic',
1334 $item->{'barcodeerror'} = 1;
1336 #warn "EAN13BARCODE FAILED:$@";
1342 elsif ( $barcodetype eq 'Code39' ) {
1345 PDF::Reuse::Barcode::Code39(
1346 x => ( $x_pos_circ + 9 ),
1347 y => ( $y_pos + 15 ),
1357 $item->{'barcodeerror'} = 1;
1359 #warn "CODE39BARCODE $value FAILED:$@";
1366 elsif ( $barcodetype eq 'Matrix2of5' ) {
1368 #warn "MATRIX ELSE:";
1370 #testing MATRIX25 barcodes hack
1371 # $value = $value.'000000000';
1374 # $value = substr( $value, 0, 12 );
1378 PDF::Reuse::Barcode::Matrix2of5(
1379 x => ( $x_pos_circ + 27 ),
1380 y => ( $y_pos + 15 ),
1390 $item->{'barcodeerror'} = 1;
1392 #warn "BARCODE FAILED:$@";
1399 elsif ( $barcodetype eq 'EAN8' ) {
1401 #testing ean8 barcodes hack
1402 $value = $value . '000000000';
1404 $value = substr( $value, 0, 8 );
1408 #warn "EAN8 ELSEIF";
1410 PDF::Reuse::Barcode::EAN8(
1411 x => ( $x_pos_circ + 42 ),
1412 y => ( $y_pos + 15 ),
1422 $item->{'barcodeerror'} = 1;
1424 #warn "BARCODE FAILED:$@";
1431 elsif ( $barcodetype eq 'UPC-E' ) {
1433 PDF::Reuse::Barcode::UPCE(
1434 x => ( $x_pos_circ + 27 ),
1435 y => ( $y_pos + 15 ),
1445 $item->{'barcodeerror'} = 1;
1447 #warn "BARCODE FAILED:$@";
1453 elsif ( $barcodetype eq 'NW7' ) {
1455 PDF::Reuse::Barcode::NW7(
1456 x => ( $x_pos_circ + 27 ),
1457 y => ( $y_pos + 15 ),
1467 $item->{'barcodeerror'} = 1;
1469 #warn "BARCODE FAILED:$@";
1475 elsif ( $barcodetype eq 'ITF' ) {
1477 PDF::Reuse::Barcode::ITF(
1478 x => ( $x_pos_circ + 27 ),
1479 y => ( $y_pos + 15 ),
1489 $item->{'barcodeerror'} = 1;
1491 #warn "BARCODE FAILED:$@";
1497 elsif ( $barcodetype eq 'Industrial2of5' ) {
1499 PDF::Reuse::Barcode::Industrial2of5(
1500 x => ( $x_pos_circ + 27 ),
1501 y => ( $y_pos + 15 ),
1510 $item->{'barcodeerror'} = 1;
1512 #warn "BARCODE FAILED:$@";
1518 elsif ( $barcodetype eq 'IATA2of5' ) {
1520 PDF::Reuse::Barcode::IATA2of5(
1521 x => ( $x_pos_circ + 27 ),
1522 y => ( $y_pos + 15 ),
1531 $item->{'barcodeerror'} = 1;
1533 #warn "BARCODE FAILED:$@";
1540 elsif ( $barcodetype eq 'COOP2of5' ) {
1542 PDF::Reuse::Barcode::COOP2of5(
1543 x => ( $x_pos_circ + 27 ),
1544 y => ( $y_pos + 15 ),
1553 $item->{'barcodeerror'} = 1;
1555 #warn "BARCODE FAILED:$@";
1561 elsif ( $barcodetype eq 'UPC-A' ) {
1564 PDF::Reuse::Barcode::UPCA(
1565 x => ( $x_pos_circ + 27 ),
1566 y => ( $y_pos + 15 ),
1575 $item->{'barcodeerror'} = 1;
1577 #warn "BARCODE FAILED:$@";
1586 =head2 draw_boundaries
1588 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1589 $y_pos, $spine_width, $label_height, $circ_width)
1591 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1596 sub draw_boundaries {
1599 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1600 $spine_width, $label_height, $circ_width
1603 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1604 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1607 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1609 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1611 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1612 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1613 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1615 $y_pos = ( $y_pos - $label_height );
1622 sub drawbox { $lower_left_x, $lower_left_y,
1623 $upper_right_x, $upper_right_y )
1625 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1627 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1629 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1635 my ( $llx, $lly, $urx, $ury ) = @_;
1637 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1639 my $str = "q\n"; # save the graphic state
1640 $str .= "0.5 w\n"; # border color red
1641 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1642 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1643 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1645 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1646 $str .= "B\n"; # fill (and a little more)
1647 $str .= "Q\n"; # save the graphic state
1653 END { } # module clean-up code here (global destructor)
1660 Mason James <mason@katipo.co.nz>