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 my $q ="SELECT MAX(DISTINCT batch_id) FROM $table";
279 my $sth = $dbh->prepare($q);
281 my ($batch_id) = $sth->fetchrow_array || 0;
284 if ($table eq 'patroncards') {
285 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`borrowernumber`) VALUES (?,?)");
287 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`itemnumber` ) VALUES (?,?)");
290 $sth->execute($batch_id,$_);
296 #FIXME: Needs to be ported to receive $batch_type
297 # ... this looks eerily like add_batch() ...
298 sub get_highest_batch {
299 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
301 "select distinct batch_id from $table order by batch_id desc limit 1";
302 my $sth = C4::Context->dbh->prepare($q);
304 my $data = $sth->fetchrow_hashref or return 1;
305 return ($data->{'batch_id'} || 1);
309 sub get_batches (;$) {
310 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
311 my $q = "SELECT batch_id, COUNT(*) AS num FROM $table GROUP BY batch_id";
312 my $sth = C4::Context->dbh->prepare($q);
314 my $batches = $sth->fetchall_arrayref({});
319 my ($batch_id, $batch_type) = @_;
320 warn "Deleteing batch of type $batch_type";
321 my $dbh = C4::Context->dbh;
322 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
323 my $sth = $dbh->prepare($q);
324 $sth->execute($batch_id);
328 sub get_barcode_types {
329 my ($layout_id) = @_;
330 my $layout = get_layout($layout_id);
331 my $barcode = $layout->{'barcodetype'};
334 push( @array, { code => 'CODE39', desc => 'Code 39' } );
335 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
336 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
337 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
339 foreach my $line (@array) {
340 if ( $line->{'code'} eq $barcode ) {
341 $line->{'active'} = 1;
352 $unitvalue = '1' if ( $units eq 'POINT' );
353 $unitvalue = '2.83464567' if ( $units eq 'MM' );
354 $unitvalue = '28.3464567' if ( $units eq 'CM' );
355 $unitvalue = 72 if ( $units eq 'INCH' );
359 sub GetTextWrapCols {
360 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
364 # my $textlimit = $label_width - ($left_text_margin);
365 my $textlimit = $label_width - ( 3 * $left_text_margin);
367 while ( $strwidth < $textlimit ) {
368 $strwidth = prStrWidth( $string, $font, $fontsize );
369 $string = $string . '0';
370 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
376 sub GetActiveLabelTemplate {
377 my $dbh = C4::Context->dbh;
378 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
379 my $sth = $dbh->prepare($query);
381 my $active_tmpl = $sth->fetchrow_hashref;
386 sub GetSingleLabelTemplate {
388 my $dbh = C4::Context->dbh;
389 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
390 my $sth = $dbh->prepare($query);
391 $sth->execute($tmpl_id);
392 my $template = $sth->fetchrow_hashref;
397 sub SetActiveTemplate {
401 my $dbh = C4::Context->dbh;
402 my $query = " UPDATE labels_templates SET active = NULL";
403 my $sth = $dbh->prepare($query);
406 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
407 $sth = $dbh->prepare($query);
408 $sth->execute($tmpl_id);
412 sub set_active_layout {
414 my ($layout_id) = @_;
415 my $dbh = C4::Context->dbh;
416 my $query = " UPDATE labels_conf SET active = NULL";
417 my $sth = $dbh->prepare($query);
420 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
421 $sth = $dbh->prepare($query);
422 $sth->execute($layout_id);
428 my $dbh = C4::Context->dbh;
429 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
430 my $sth = $dbh->prepare($query);
431 $sth->execute($tmpl_id);
437 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
438 $page_height, $label_width, $label_height, $topmargin,
439 $leftmargin, $cols, $rows, $colgap,
440 $rowgap, $font, $fontsize, $units
442 $debug and warn "Passed \$font:$font";
443 my $dbh = C4::Context->dbh;
445 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
446 page_height=?, label_width=?, label_height=?, topmargin=?,
447 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
451 my $sth = $dbh->prepare($query);
453 $tmpl_code, $tmpl_desc, $page_width, $page_height,
454 $label_width, $label_height, $topmargin, $leftmargin,
455 $cols, $rows, $colgap, $rowgap,
456 $font, $fontsize, $units, $tmpl_id
458 my $dberror = $sth->errstr;
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
472 my $dbh = C4::Context->dbh;
474 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
475 page_height, label_width, label_height, topmargin,
476 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
477 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
479 my $sth = $dbh->prepare($query);
481 $tmpl_code, $tmpl_desc, $page_width, $page_height,
482 $label_width, $label_height, $topmargin, $leftmargin,
483 $cols, $rows, $colgap, $rowgap,
484 $font, $fontsize, $units
486 my $dberror = $sth->errstr;
491 sub GetAllLabelTemplates {
492 my $dbh = C4::Context->dbh;
494 # get the actual items to be printed.
496 my $query = " Select * from labels_templates ";
497 my $sth = $dbh->prepare($query);
500 while ( my $data = $sth->fetchrow_hashref ) {
501 push( @resultsloop, $data );
505 #warn Dumper @resultsloop;
513 $barcodetype, $title, $subtitle, $isbn, $issn,
514 $itemtype, $bcn, $text_justify, $callnum_split,
515 $itemcallnumber, $author, $tmpl_id,
516 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
519 my $dbh = C4::Context->dbh;
520 my $query2 = "update labels_conf set active = NULL";
521 my $sth2 = $dbh->prepare($query2);
523 $query2 = "INSERT INTO labels_conf
524 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
525 text_justify, callnum_split, itemcallnumber, author, printingtype,
526 guidebox, startlabel, layoutname, formatstring, active )
527 values ( ?, ?,?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?,?,?, 1 )";
528 $sth2 = $dbh->prepare($query2);
530 $barcodetype, $title, $subtitle, $isbn, $issn,
532 $itemtype, $bcn, $text_justify, $callnum_split,
533 $itemcallnumber, $author, $printingtype,
534 $guidebox, $startlabel, $layoutname, $formatstring
538 SetActiveTemplate($tmpl_id);
545 $barcodetype, $title, $subtitle, $isbn, $issn,
546 $itemtype, $bcn, $text_justify, $callnum_split,
547 $itemcallnumber, $author, $tmpl_id,
548 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
554 my $dbh = C4::Context->dbh;
555 my $query2 = "update labels_conf set
556 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
557 itemtype=?, barcode=?, text_justify=?, callnum_split=?,
558 itemcallnumber=?, author=?, printingtype=?,
559 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
560 my $sth2 = $dbh->prepare($query2);
562 $barcodetype, $title, $subtitle, $isbn, $issn,
563 $itemtype, $bcn, $text_justify, $callnum_split,
564 $itemcallnumber, $author, $printingtype,
565 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
572 =head2 GetAllPrinterProfiles;
574 @profiles = GetAllPrinterProfiles()
576 Returns an array of references-to-hash, whos keys are .....
580 sub GetAllPrinterProfiles {
582 my $dbh = C4::Context->dbh;
584 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
585 my $sth = $dbh->prepare($query);
588 while ( my $data = $sth->fetchrow_hashref ) {
589 push( @resultsloop, $data );
596 =head2 GetSinglePrinterProfile;
598 $profile = GetSinglePrinterProfile()
600 Returns a hashref whos keys are...
604 sub GetSinglePrinterProfile {
606 my $dbh = C4::Context->dbh;
607 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
608 my $sth = $dbh->prepare($query);
609 $sth->execute($prof_id);
610 my $template = $sth->fetchrow_hashref;
617 SaveProfile('parameters')
619 When passed a set of parameters, this function updates the given profile with the new parameters.
625 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
627 my $dbh = C4::Context->dbh;
629 " UPDATE printers_profile
630 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
632 my $sth = $dbh->prepare($query);
634 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
639 =head2 CreateProfile;
641 CreateProfile('parameters')
643 When passed a set of parameters, this function creates a new profile containing those parameters
644 and returns any errors.
650 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
651 $offset_vert, $creep_horz, $creep_vert, $units
653 my $dbh = C4::Context->dbh;
655 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
656 offset_horz, offset_vert, creep_horz, creep_vert, unit)
657 VALUES(?,?,?,?,?,?,?,?,?) ";
658 my $sth = $dbh->prepare($query);
660 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
661 $offset_vert, $creep_horz, $creep_vert, $units
663 my $error = $sth->errstr;
668 =head2 DeleteProfile;
670 DeleteProfile(prof_id)
672 When passed a profile id, this function deletes that profile from the database and returns any errors.
678 my $dbh = C4::Context->dbh;
679 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
680 my $sth = $dbh->prepare($query);
681 $sth->execute($prof_id);
682 my $error = $sth->errstr;
687 =head2 GetAssociatedProfile;
689 $assoc_prof = GetAssociatedProfile(tmpl_id)
691 When passed a template id, this function returns the parameters from the currently associated printer profile
692 in a hashref where key=fieldname and value=fieldvalue.
696 sub GetAssociatedProfile {
698 my $dbh = C4::Context->dbh;
699 # First we find out the prof_id for the associated profile...
700 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
701 my $sth = $dbh->prepare($query);
702 $sth->execute($tmpl_id);
703 my $assoc_prof = $sth->fetchrow_hashref;
705 # Then we retrieve that profile and return it to the caller...
706 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
710 =head2 SetAssociatedProfile;
712 SetAssociatedProfile($prof_id, $tmpl_id)
714 When passed both a profile id and template id, this function establishes an association between the two. No more
715 than one profile may be associated with any given template at the same time.
719 sub SetAssociatedProfile {
721 my ($prof_id, $tmpl_id) = @_;
723 my $dbh = C4::Context->dbh;
724 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
725 my $sth = $dbh->prepare($query);
726 $sth->execute($prof_id, $tmpl_id, $prof_id);
731 =head2 GetLabelItems;
733 $options = GetLabelItems()
735 Returns an array of references-to-hash, whos keys are the fields from the biblio, biblioitems, items and labels tables in the Koha database.
741 my $dbh = C4::Context->dbh;
743 my @resultsloop = ();
754 $sth = $dbh->prepare($query3);
755 $sth->execute($batch_id);
761 $sth = $dbh->prepare($query3);
764 my $cnt = $sth->rows;
766 while ( my $data = $sth->fetchrow_hashref ) {
768 # lets get some summary info from each item
770 # FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten.
771 # Something like this, perhaps, but this also causes problems because we need more fields sometimes.
772 # SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
773 "SELECT bi.*, i.*, b.*
774 FROM items AS i, biblioitems AS bi ,biblio AS b
775 WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber";
776 my $sth1 = $dbh->prepare($query1);
777 $sth1->execute( $data->{'itemnumber'} );
779 my $data1 = $sth1->fetchrow_hashref();
780 $data1->{'labelno'} = $i1;
781 $data1->{'labelid'} = $data->{'labelid'};
782 $data1->{'batch_id'} = $batch_id;
783 $data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
785 push( @resultsloop, $data1 );
805 =head2 GetBarcodeData
809 Parse labels_conf.formatstring value
810 (one value of the csv, which has already been split)
811 and return string from koha tables or MARC record.
818 my ( $f, $item, $record ) = @_;
819 my $kohatables = &_descKohaTables();
821 my $match_kohatable = join(
824 @{ $kohatables->{biblio} },
825 @{ $kohatables->{biblioitems} },
826 @{ $kohatables->{items} }
831 if ( $f =~ /^'(.*)'.*/ ) {
832 # single quotes indicate a static text string.
836 elsif ( $f =~ /^($match_kohatable).*/ ) {
837 $datastring .= $item->{$f};
840 elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
841 my ($field,$subf,$ws) = ($1,$2,$3);
843 my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
844 my @marcfield = $record->field($field);
846 if($field eq $itemtag) { # item-level data, we need to get the right item.
847 foreach my $itemfield (@marcfield) {
848 if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
849 $datastring .= $itemfield->subfield($subf ) . $ws;
853 } else { # bib-level data, we'll take the first matching tag/subfield.
854 $datastring .= $marcfield[0]->subfield($subf) . $ws ;
860 warn "failed to parse label formatstring: $f";
861 last; # Failed to match
867 =head2 descKohaTables
869 Return a hashref of an array of hashes,
874 sub _descKohaTables {
875 my $dbh = C4::Context->dbh();
877 for my $table ( 'biblio','biblioitems','items' ) {
878 my $sth = $dbh->column_info(undef,undef,$table,'%');
879 while (my $info = $sth->fetchrow_hashref()){
880 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
887 sub GetPatronCardItems {
889 my ( $batch_id ) = @_;
892 my $dbh = C4::Context->dbh;
893 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
894 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
895 my $sth = $dbh->prepare($query);
896 $sth->execute($batch_id);
898 while ( my $data = $sth->fetchrow_hashref ) {
899 my $patron_data = GetMember( $data->{'borrowernumber'} );
900 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
901 $patron_data->{'cardno'} = $cardno;
902 $patron_data->{'cardid'} = $data->{'cardid'};
903 $patron_data->{'batch_id'} = $batch_id;
904 push( @resultsloop, $patron_data );
912 sub deduplicate_batch {
913 my ( $batch_id, $batch_type ) = @_;
916 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
917 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
920 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
924 my $sth = C4::Context->dbh->prepare($query);
925 $sth->execute($batch_id);
926 warn $sth->errstr if $sth->errstr;
927 $sth->rows or return undef, $sth->errstr;
933 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
934 ORDER BY timestamp ASC
937 while (my $data = $sth->fetchrow_hashref()) {
938 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
939 my $limit = $data->{count} - 1 or next;
940 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
941 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
942 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
943 $sth2->execute($batch_id, $itemnumber) and
944 $killed += ($data->{count} - 1);
945 warn $sth2->errstr if $sth2->errstr;
947 return $killed, undef;
952 my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
954 # lccn example 'HE8700.7 .P6T44 1983';
957 ([0-9]+\.*[0-9]*) # 8700.7
959 (\.*[a-zA-Z0-9]*) # P6T44
964 # strip something occuring spaces too
965 $splits[0] =~ s/\s+$//;
966 $splits[1] =~ s/\s+$//;
967 $splits[2] =~ s/\s+$//;
974 $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
976 # ddcn example R220.3 H2793Z H32 c.2
977 my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
978 ([0-9]+\.[0-9]*) # 220.3
979 \s? # space (not requiring anything beyond the call number)
980 ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
981 \s? # space if it exists
982 ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
983 \s? # space if ie exists
984 ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
992 # Split fiction call numbers based on spaces
995 if ($fcn =~ m/([A-Za-z0-9]+)(\W?).*?/x) {
996 push (@fcn_split, $1);
1000 last SPLIT_FCN; # No match, break out of the loop
1008 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1009 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
1011 # Replaced item's itemtype with the more user-friendly description...
1012 my $dbh = C4::Context->dbh;
1013 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
1015 while ( my $data = $sth->fetchrow_hashref ) {
1016 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
1017 $$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
1022 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
1023 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.).
1025 my $layout_id = $$conf_data->{'id'};
1027 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1029 my @str_fields = get_text_fields($layout_id, 'codes' );
1030 my $record = GetMarcBiblio($$item->{biblionumber});
1031 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1032 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1034 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1036 # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
1037 my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
1038 for my $field (@str_fields) {
1039 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1040 if ($field->{'code'} eq 'itemtype') {
1041 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1043 elsif ($$conf_data->{'formatstring'}) {
1044 # if labels_conf.formatstring has a value, then it overrides the hardcoded option.
1045 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1048 $field->{data} = $$item->{$field->{'code'}} ;
1050 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1051 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1052 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1053 my $font = prFont($fontname);
1054 # if the display option for this field is selected in the DB,
1055 # and the item record has some values for this field, display it.
1056 # Or if there is a csv list of fields to display, display them.
1057 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1059 my $str = $field->{data} ;
1060 # strip out naughty existing nl/cr's
1064 my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? )
1065 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
1066 if ($cn_source eq 'lcc') {
1067 @strings = split_lccn($str);
1068 @strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number
1069 push (@strings, $str) if !@strings; # If it was not that, send it on unsplit
1070 } elsif ($cn_source eq 'ddc') {
1071 @strings = split_ddcn($str);
1072 @strings = split_fcn($str) if !@strings;
1073 push (@strings, $str) if !@strings;
1075 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1076 push @strings, $str;
1079 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1080 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1081 $str =~ s/\)/\\\)/g;
1082 # Wrap text lines exceeding $text_wrap_cols length...
1083 $Text::Wrap::columns = $text_wrap_cols;
1084 my @line = split(/\n/ ,wrap('', '', $str));
1085 # If this is a title field, limit to two lines; all others limit to one...
1086 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1087 while (scalar(@line) > 2) {
1091 while (scalar(@line) > 1) {
1095 push(@strings, @line);
1097 # loop for each string line
1098 foreach my $str (@strings) {
1100 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1101 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1102 $hPos = $x_pos + $label_width - ( $left_text_margin + $stringwidth );
1103 } elsif($$conf_data->{'text_justify'} eq 'C') {
1104 # some code to try and center each line on the label based on font size and string point width...
1105 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1106 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1107 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1109 $hPos = ( $x_pos + $left_text_margin );
1111 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1112 $vPos = $vPos - $line_spacer;
1119 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1120 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1124 sub DrawPatronCardText {
1126 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1127 $text_wrap_cols, $text, $printingtype )
1130 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1132 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1133 my $font = prFont($fontname);
1137 foreach my $line (keys %$text) {
1138 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1139 # some code to try and center each line on the label based on font size and string point width...
1140 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1141 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1142 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1144 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1145 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.).
1146 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1150 # Not used anywhere.
1154 # my ($fontsize) = @_;
1156 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1162 # x and y are from the top-left :)
1163 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1164 my $num_of_bars = length($barcode);
1165 my $bar_width = $width * .8; # %80 of length of label width
1166 my $tot_bar_length = 0;
1168 my $guard_length = 10;
1169 my $xsize_ratio = 0;
1171 if ( $barcodetype eq 'CODE39' ) {
1172 $bar_length = '17.5';
1174 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1175 $xsize_ratio = ( $bar_width / $tot_bar_length );
1177 PDF::Reuse::Barcode::Code39(
1178 x => ( $x_pos + ( $width / 10 ) ),
1179 y => ( $y_pos + ( $height / 10 ) ),
1180 value => "*$barcode*",
1181 ySize => ( .02 * $height ),
1182 xSize => $xsize_ratio,
1187 warn "$barcodetype, $barcode FAILED:$@";
1191 elsif ( $barcodetype eq 'CODE39MOD' ) {
1193 # get modulo43 checksum
1194 my $c39 = CheckDigits('code_39');
1195 $barcode = $c39->complete($barcode);
1199 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1200 $xsize_ratio = ( $bar_width / $tot_bar_length );
1202 PDF::Reuse::Barcode::Code39(
1203 x => ( $x_pos + ( $width / 10 ) ),
1204 y => ( $y_pos + ( $height / 10 ) ),
1205 value => "*$barcode*",
1206 ySize => ( .02 * $height ),
1207 xSize => $xsize_ratio,
1213 warn "$barcodetype, $barcode FAILED:$@";
1216 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1218 # get modulo43 checksum
1219 my $c39_10 = CheckDigits('visa');
1220 $barcode = $c39_10->complete($barcode);
1224 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1225 $xsize_ratio = ( $bar_width / $tot_bar_length );
1227 PDF::Reuse::Barcode::Code39(
1228 x => ( $x_pos + ( $width / 10 ) ),
1229 y => ( $y_pos + ( $height / 10 ) ),
1230 value => "*$barcode*",
1231 ySize => ( .02 * $height ),
1232 xSize => $xsize_ratio,
1239 warn "$barcodetype, $barcode FAILED:$@";
1244 elsif ( $barcodetype eq 'COOP2OF5' ) {
1245 $bar_length = '9.43333333333333';
1247 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1248 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1250 PDF::Reuse::Barcode::COOP2of5(
1251 x => ( $x_pos + ( $width / 10 ) ),
1252 y => ( $y_pos + ( $height / 10 ) ),
1254 ySize => ( .02 * $height ),
1255 xSize => $xsize_ratio,
1259 warn "$barcodetype, $barcode FAILED:$@";
1263 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1264 $bar_length = '13.1333333333333';
1266 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1267 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1269 PDF::Reuse::Barcode::Industrial2of5(
1270 x => ( $x_pos + ( $width / 10 ) ),
1271 y => ( $y_pos + ( $height / 10 ) ),
1273 ySize => ( .02 * $height ),
1274 xSize => $xsize_ratio,
1278 warn "$barcodetype, $barcode FAILED:$@";
1282 my $moo2 = $tot_bar_length * $xsize_ratio;
1284 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1285 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1288 =head2 build_circ_barcode;
1290 build_circ_barcode( $x_pos, $y_pos, $barcode,
1291 $barcodetype, \$item);
1293 $item is the result of a previous call to GetLabelItems();
1298 sub build_circ_barcode {
1299 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1301 #warn Dumper \$item;
1303 #warn "value = $value\n";
1307 if ( $barcodetype eq 'EAN13' ) {
1309 #testing EAN13 barcodes hack
1310 $value = $value . '000000000';
1312 $value = substr( $value, 0, 12 );
1316 PDF::Reuse::Barcode::EAN13(
1317 x => ( $x_pos_circ + 27 ),
1318 y => ( $y_pos + 15 ),
1326 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1327 # i think its embedding extra fonts in the pdf file.
1328 # mode => 'graphic',
1332 $item->{'barcodeerror'} = 1;
1334 #warn "EAN13BARCODE FAILED:$@";
1340 elsif ( $barcodetype eq 'Code39' ) {
1343 PDF::Reuse::Barcode::Code39(
1344 x => ( $x_pos_circ + 9 ),
1345 y => ( $y_pos + 15 ),
1355 $item->{'barcodeerror'} = 1;
1357 #warn "CODE39BARCODE $value FAILED:$@";
1364 elsif ( $barcodetype eq 'Matrix2of5' ) {
1366 #warn "MATRIX ELSE:";
1368 #testing MATRIX25 barcodes hack
1369 # $value = $value.'000000000';
1372 # $value = substr( $value, 0, 12 );
1376 PDF::Reuse::Barcode::Matrix2of5(
1377 x => ( $x_pos_circ + 27 ),
1378 y => ( $y_pos + 15 ),
1388 $item->{'barcodeerror'} = 1;
1390 #warn "BARCODE FAILED:$@";
1397 elsif ( $barcodetype eq 'EAN8' ) {
1399 #testing ean8 barcodes hack
1400 $value = $value . '000000000';
1402 $value = substr( $value, 0, 8 );
1406 #warn "EAN8 ELSEIF";
1408 PDF::Reuse::Barcode::EAN8(
1409 x => ( $x_pos_circ + 42 ),
1410 y => ( $y_pos + 15 ),
1420 $item->{'barcodeerror'} = 1;
1422 #warn "BARCODE FAILED:$@";
1429 elsif ( $barcodetype eq 'UPC-E' ) {
1431 PDF::Reuse::Barcode::UPCE(
1432 x => ( $x_pos_circ + 27 ),
1433 y => ( $y_pos + 15 ),
1443 $item->{'barcodeerror'} = 1;
1445 #warn "BARCODE FAILED:$@";
1451 elsif ( $barcodetype eq 'NW7' ) {
1453 PDF::Reuse::Barcode::NW7(
1454 x => ( $x_pos_circ + 27 ),
1455 y => ( $y_pos + 15 ),
1465 $item->{'barcodeerror'} = 1;
1467 #warn "BARCODE FAILED:$@";
1473 elsif ( $barcodetype eq 'ITF' ) {
1475 PDF::Reuse::Barcode::ITF(
1476 x => ( $x_pos_circ + 27 ),
1477 y => ( $y_pos + 15 ),
1487 $item->{'barcodeerror'} = 1;
1489 #warn "BARCODE FAILED:$@";
1495 elsif ( $barcodetype eq 'Industrial2of5' ) {
1497 PDF::Reuse::Barcode::Industrial2of5(
1498 x => ( $x_pos_circ + 27 ),
1499 y => ( $y_pos + 15 ),
1508 $item->{'barcodeerror'} = 1;
1510 #warn "BARCODE FAILED:$@";
1516 elsif ( $barcodetype eq 'IATA2of5' ) {
1518 PDF::Reuse::Barcode::IATA2of5(
1519 x => ( $x_pos_circ + 27 ),
1520 y => ( $y_pos + 15 ),
1529 $item->{'barcodeerror'} = 1;
1531 #warn "BARCODE FAILED:$@";
1538 elsif ( $barcodetype eq 'COOP2of5' ) {
1540 PDF::Reuse::Barcode::COOP2of5(
1541 x => ( $x_pos_circ + 27 ),
1542 y => ( $y_pos + 15 ),
1551 $item->{'barcodeerror'} = 1;
1553 #warn "BARCODE FAILED:$@";
1559 elsif ( $barcodetype eq 'UPC-A' ) {
1562 PDF::Reuse::Barcode::UPCA(
1563 x => ( $x_pos_circ + 27 ),
1564 y => ( $y_pos + 15 ),
1573 $item->{'barcodeerror'} = 1;
1575 #warn "BARCODE FAILED:$@";
1584 =head2 draw_boundaries
1586 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1587 $y_pos, $spine_width, $label_height, $circ_width)
1589 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1594 sub draw_boundaries {
1597 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1598 $spine_width, $label_height, $circ_width
1601 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1602 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1605 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1607 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1609 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1610 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1611 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1613 $y_pos = ( $y_pos - $label_height );
1620 sub drawbox { $lower_left_x, $lower_left_y,
1621 $upper_right_x, $upper_right_y )
1623 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1625 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1627 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1633 my ( $llx, $lly, $urx, $ury ) = @_;
1635 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1637 my $str = "q\n"; # save the graphic state
1638 $str .= "0.5 w\n"; # border color red
1639 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1640 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1641 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1643 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1644 $str .= "B\n"; # fill (and a little more)
1645 $str .= "Q\n"; # save the graphic state
1651 END { } # module clean-up code here (global destructor)
1658 Mason James <mason@katipo.co.nz>