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;
32 # use Smart::Comments;
39 &get_label_options &GetLabelItems
40 &build_circ_barcode &draw_boundaries
41 &drawbox &GetActiveLabelTemplate
42 &GetAllLabelTemplates &DeleteTemplate
43 &GetSingleLabelTemplate &SaveTemplate
44 &CreateTemplate &SetActiveTemplate
45 &SaveConf &DrawSpineText &GetTextWrapCols
46 &GetUnitsValue &DrawBarcode &DrawPatronCardText
47 &get_printingtypes &GetPatronCardItems
50 &get_batches &delete_batch
54 get_layout &save_layout &add_layout
57 &delete_layout &get_active_layout
60 &GetAllPrinterProfiles &GetSinglePrinterProfile
61 &SaveProfile &CreateProfile &DeleteProfile
62 &GetAssociatedProfile &SetAssociatedProfile
69 C4::Labels - Functions for printing spine labels and barcodes in Koha
75 =item get_label_options;
77 $options = get_label_options()
79 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
84 sub get_label_options {
85 my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout
86 my $sth = C4::Context->dbh->prepare($query2);
88 return $sth->fetchrow_hashref;
92 my $dbh = C4::Context->dbh;
94 my $query = " Select * from labels_conf";
95 my $sth = $dbh->prepare($query);
98 while ( my $data = $sth->fetchrow_hashref ) {
100 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
101 push( @resultsloop, $data );
108 my ($layout_id) = @_;
109 my $dbh = C4::Context->dbh;
111 # get the actual items to be printed.
112 my $query = " Select * from labels_conf where id = ?";
113 my $sth = $dbh->prepare($query);
114 $sth->execute($layout_id);
115 my $data = $sth->fetchrow_hashref;
120 sub get_active_layout {
121 my $query = " Select * from labels_conf where active = 1"; # FIXME: exact same as get_label_options
122 my $sth = C4::Context->dbh->prepare($query);
124 return $sth->fetchrow_hashref;
128 my ($layout_id) = @_;
129 my $dbh = C4::Context->dbh;
131 # get the actual items to be printed.
132 my $query = "delete from labels_conf where id = ?";
133 my $sth = $dbh->prepare($query);
134 $sth->execute($layout_id);
138 sub get_printingtypes {
139 my ($layout_id) = @_;
141 # FIXME: hard coded print types
142 push( @printtypes, { code => 'BAR', desc => "barcode only" } );
143 push( @printtypes, { code => 'BIB', desc => "biblio only" } );
144 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
145 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
146 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
147 push( @printtypes, { code => 'CSV', desc => "csv output" } );
148 push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
150 my $conf = get_layout($layout_id);
151 my $active_printtype = $conf->{'printingtype'};
153 # lop thru layout, insert selected to hash
155 foreach my $printtype (@printtypes) {
156 if ( $printtype->{'code'} eq $active_printtype ) {
157 $printtype->{'active'} = 1;
163 # this sub (build_text_dropbox) is deprecated and should be deleted.
166 sub build_text_dropbox {
169 # my @fields = get_text_fields();
170 # my $field_count = scalar @fields;
171 my $field_count = 10; # <----------- FIXME hard coded
175 ? push( @lines, { num => '', selected => '1' } )
176 : push( @lines, { num => '' } );
177 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
178 my $line = { num => "$i" };
179 $line->{'selected'} = 1 if $i eq $order;
180 push( @lines, $line );
183 # add a blank row too
188 sub get_text_fields {
189 my ($layout_id, $sorttype) = @_;
192 my $sortorder = get_layout($layout_id);
193 if( $sortorder->{formatstring}) {
195 return $sortorder->{formatstring} ;
197 my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } ) ;
198 my $line= $sortorder->{formatstring} ;
199 my $status = $csv->parse( $line );
200 @sorted_fields = map {{ 'code' => $_ , desc => $_ } } $csv->fields() ;
201 $error = $csv->error_input();
202 warn $error if $error ; # TODO - do more with this.
205 # These fields are hardcoded based on the template for label-edit-layout.pl
210 order => $sortorder->{'itemtype'}
215 order => $sortorder->{'dewey'}
220 order => $sortorder->{'issn'}
225 order => $sortorder->{'isbn'}
229 desc => "Classification",
230 order => $sortorder->{'class'}
235 order => $sortorder->{'subclass'}
240 order => $sortorder->{'barcode'}
245 order => $sortorder->{'author'}
250 order => $sortorder->{'title'}
253 code => 'itemcallnumber',
254 desc => "Call Number",
255 order => $sortorder->{'itemcallnumber'}
260 order => $sortorder->{'subtitle'}
266 foreach my $field (@text_fields) {
267 push( @new_fields, $field ) if $field->{'order'} > 0;
270 @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
272 # if we have a 'formatstring', then we ignore these hardcoded fields.
275 if ($sorttype eq 'codes') { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit
276 return @sorted_fields;
278 foreach my $field (@sorted_fields) {
279 $active_fields .= "$field->{'desc'} ";
281 return $active_fields;
288 add_batch($batch_type,\@batch_list);
289 if $batch_list is supplied,
290 create a new batch with those items.
291 else, return the next available batch_id.
294 sub add_batch ($;$) {
295 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
296 my $batch_list = (@_) ? shift : undef;
297 my $dbh = C4::Context->dbh;
298 my $q ="SELECT MAX(DISTINCT batch_id) FROM $table";
299 my $sth = $dbh->prepare($q);
301 my ($batch_id) = $sth->fetchrow_array || 0;
304 if ($table eq 'patroncards') {
305 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`borrowernumber`) VALUES (?,?)");
307 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`itemnumber` ) VALUES (?,?)");
310 $sth->execute($batch_id,$_);
316 #FIXME: Needs to be ported to receive $batch_type
317 # ... this looks eerily like add_batch() ...
318 sub get_highest_batch {
319 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
321 "select distinct batch_id from $table order by batch_id desc limit 1";
322 my $sth = C4::Context->dbh->prepare($q);
324 my $data = $sth->fetchrow_hashref or return 1;
325 return ($data->{'batch_id'} || 1);
329 sub get_batches (;$) {
330 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
331 my $q = "SELECT batch_id, COUNT(*) AS num FROM $table GROUP BY batch_id";
332 my $sth = C4::Context->dbh->prepare($q);
334 my $batches = $sth->fetchall_arrayref({});
339 my ($batch_id, $batch_type) = @_;
340 warn "Deleteing batch of type $batch_type";
341 my $dbh = C4::Context->dbh;
342 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
343 my $sth = $dbh->prepare($q);
344 $sth->execute($batch_id);
348 sub get_barcode_types {
349 my ($layout_id) = @_;
350 my $layout = get_layout($layout_id);
351 my $barcode = $layout->{'barcodetype'};
354 push( @array, { code => 'CODE39', desc => 'Code 39' } );
355 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
356 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
357 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
359 foreach my $line (@array) {
360 if ( $line->{'code'} eq $barcode ) {
361 $line->{'active'} = 1;
372 $unitvalue = '1' if ( $units eq 'POINT' );
373 $unitvalue = '2.83464567' if ( $units eq 'MM' );
374 $unitvalue = '28.3464567' if ( $units eq 'CM' );
375 $unitvalue = 72 if ( $units eq 'INCH' );
379 sub GetTextWrapCols {
380 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
384 # my $textlimit = $label_width - ($left_text_margin);
385 my $textlimit = $label_width - ( 3 * $left_text_margin);
387 while ( $strwidth < $textlimit ) {
388 $strwidth = prStrWidth( $string, $font, $fontsize );
389 $string = $string . '0';
390 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
396 sub GetActiveLabelTemplate {
397 my $dbh = C4::Context->dbh;
398 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
399 my $sth = $dbh->prepare($query);
401 my $active_tmpl = $sth->fetchrow_hashref;
406 sub GetSingleLabelTemplate {
408 my $dbh = C4::Context->dbh;
409 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
410 my $sth = $dbh->prepare($query);
411 $sth->execute($tmpl_id);
412 my $template = $sth->fetchrow_hashref;
417 sub SetActiveTemplate {
421 my $dbh = C4::Context->dbh;
422 my $query = " UPDATE labels_templates SET active = NULL";
423 my $sth = $dbh->prepare($query);
426 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
427 $sth = $dbh->prepare($query);
428 $sth->execute($tmpl_id);
432 sub set_active_layout {
434 my ($layout_id) = @_;
435 my $dbh = C4::Context->dbh;
436 my $query = " UPDATE labels_conf SET active = NULL";
437 my $sth = $dbh->prepare($query);
440 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
441 $sth = $dbh->prepare($query);
442 $sth->execute($layout_id);
448 my $dbh = C4::Context->dbh;
449 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
450 my $sth = $dbh->prepare($query);
451 $sth->execute($tmpl_id);
457 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
458 $page_height, $label_width, $label_height, $topmargin,
459 $leftmargin, $cols, $rows, $colgap,
460 $rowgap, $font, $fontsize, $units
462 $debug and warn "Passed \$font:$font";
463 my $dbh = C4::Context->dbh;
465 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
466 page_height=?, label_width=?, label_height=?, topmargin=?,
467 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
471 my $sth = $dbh->prepare($query);
473 $tmpl_code, $tmpl_desc, $page_width, $page_height,
474 $label_width, $label_height, $topmargin, $leftmargin,
475 $cols, $rows, $colgap, $rowgap,
476 $font, $fontsize, $units, $tmpl_id
478 my $dberror = $sth->errstr;
486 $tmpl_code, $tmpl_desc, $page_width, $page_height,
487 $label_width, $label_height, $topmargin, $leftmargin,
488 $cols, $rows, $colgap, $rowgap,
489 $font, $fontsize, $units
492 my $dbh = C4::Context->dbh;
494 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
495 page_height, label_width, label_height, topmargin,
496 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
497 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
499 my $sth = $dbh->prepare($query);
501 $tmpl_code, $tmpl_desc, $page_width, $page_height,
502 $label_width, $label_height, $topmargin, $leftmargin,
503 $cols, $rows, $colgap, $rowgap,
504 $font, $fontsize, $units
506 my $dberror = $sth->errstr;
511 sub GetAllLabelTemplates {
512 my $dbh = C4::Context->dbh;
514 # get the actual items to be printed.
516 my $query = " Select * from labels_templates ";
517 my $sth = $dbh->prepare($query);
520 while ( my $data = $sth->fetchrow_hashref ) {
521 push( @resultsloop, $data );
525 #warn Dumper @resultsloop;
533 $barcodetype, $title, $subtitle, $isbn, $issn,
534 $itemtype, $bcn, $dcn, $classif,
535 $subclass, $itemcallnumber, $author, $tmpl_id,
536 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
539 my $dbh = C4::Context->dbh;
540 my $query2 = "update labels_conf set active = NULL";
541 my $sth2 = $dbh->prepare($query2);
543 $query2 = "INSERT INTO labels_conf
544 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
545 dewey, classification, subclass, itemcallnumber, author, printingtype,
546 guidebox, startlabel, layoutname, formatstring, active )
547 values ( ?, ?,?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
548 $sth2 = $dbh->prepare($query2);
550 $barcodetype, $title, $subtitle, $isbn, $issn,
552 $itemtype, $bcn, $dcn, $classif,
553 $subclass, $itemcallnumber, $author, $printingtype,
554 $guidebox, $startlabel, $layoutname, $formatstring
558 SetActiveTemplate($tmpl_id);
565 $barcodetype, $title, $subtitle, $isbn, $issn,
566 $itemtype, $bcn, $dcn, $classif,
567 $subclass, $itemcallnumber, $author, $tmpl_id,
568 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
574 my $dbh = C4::Context->dbh;
575 my $query2 = "update labels_conf set
576 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
577 itemtype=?, barcode=?, dewey=?, classification=?,
578 subclass=?, itemcallnumber=?, author=?, printingtype=?,
579 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
580 my $sth2 = $dbh->prepare($query2);
582 $barcodetype, $title, $subtitle, $isbn, $issn,
583 $itemtype, $bcn, $dcn, $classif,
584 $subclass, $itemcallnumber, $author, $printingtype,
585 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
592 =item GetAllPrinterProfiles;
594 @profiles = GetAllPrinterProfiles()
596 Returns an array of references-to-hash, whos keys are .....
600 sub GetAllPrinterProfiles {
602 my $dbh = C4::Context->dbh;
604 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
605 my $sth = $dbh->prepare($query);
608 while ( my $data = $sth->fetchrow_hashref ) {
609 push( @resultsloop, $data );
616 =item GetSinglePrinterProfile;
618 $profile = GetSinglePrinterProfile()
620 Returns a hashref whos keys are...
624 sub GetSinglePrinterProfile {
626 my $dbh = C4::Context->dbh;
627 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
628 my $sth = $dbh->prepare($query);
629 $sth->execute($prof_id);
630 my $template = $sth->fetchrow_hashref;
637 SaveProfile('parameters')
639 When passed a set of parameters, this function updates the given profile with the new parameters.
645 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
647 my $dbh = C4::Context->dbh;
649 " UPDATE printers_profile
650 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
652 my $sth = $dbh->prepare($query);
654 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
661 CreateProfile('parameters')
663 When passed a set of parameters, this function creates a new profile containing those parameters
664 and returns any errors.
670 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
671 $offset_vert, $creep_horz, $creep_vert, $units
673 my $dbh = C4::Context->dbh;
675 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
676 offset_horz, offset_vert, creep_horz, creep_vert, unit)
677 VALUES(?,?,?,?,?,?,?,?,?) ";
678 my $sth = $dbh->prepare($query);
680 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
681 $offset_vert, $creep_horz, $creep_vert, $units
683 my $error = $sth->errstr;
690 DeleteProfile(prof_id)
692 When passed a profile id, this function deletes that profile from the database and returns any errors.
698 my $dbh = C4::Context->dbh;
699 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
700 my $sth = $dbh->prepare($query);
701 $sth->execute($prof_id);
702 my $error = $sth->errstr;
707 =item GetAssociatedProfile;
709 $assoc_prof = GetAssociatedProfile(tmpl_id)
711 When passed a template id, this function returns the parameters from the currently associated printer profile
712 in a hashref where key=fieldname and value=fieldvalue.
716 sub GetAssociatedProfile {
718 my $dbh = C4::Context->dbh;
719 # First we find out the prof_id for the associated profile...
720 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
721 my $sth = $dbh->prepare($query);
722 $sth->execute($tmpl_id);
723 my $assoc_prof = $sth->fetchrow_hashref;
725 # Then we retrieve that profile and return it to the caller...
726 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
730 =item SetAssociatedProfile;
732 SetAssociatedProfile($prof_id, $tmpl_id)
734 When passed both a profile id and template id, this function establishes an association between the two. No more
735 than one profile may be associated with any given template at the same time.
739 sub SetAssociatedProfile {
741 my ($prof_id, $tmpl_id) = @_;
743 my $dbh = C4::Context->dbh;
744 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
745 my $sth = $dbh->prepare($query);
746 $sth->execute($prof_id, $tmpl_id, $prof_id);
752 $options = GetLabelItems()
754 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
761 my $dbh = C4::Context->dbh;
763 my @resultsloop = ();
769 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
770 $sth = $dbh->prepare($query3);
771 $sth->execute($batch_id);
776 my $query3 = "Select * from labels";
777 $sth = $dbh->prepare($query3);
780 my $cnt = $sth->rows;
782 while ( my $data = $sth->fetchrow_hashref ) {
784 # lets get some summary info from each item
786 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
787 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
788 bi.biblionumber=b.biblionumber";
790 my $sth1 = $dbh->prepare($query1);
791 $sth1->execute( $data->{'itemnumber'} );
793 my $data1 = $sth1->fetchrow_hashref();
794 $data1->{'labelno'} = $i1;
795 $data1->{'labelid'} = $data->{'labelid'};
796 $data1->{'batch_id'} = $batch_id;
797 $data1->{'summary'} =
798 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
800 push( @resultsloop, $data1 );
812 barcode title subtitle
813 dewey isbn issn author class
814 itemtype subclass itemcallnumber
822 Parse labels_conf.formatstring value
823 (one value of the csv, which has already been split)
824 and return string from koha tables or MARC record.
829 my ($f,$item,$record) = @_;
830 my $kohatables= &_descKohaTables();
833 my $match_kohatable = join('|', (@{$kohatables->{biblio}},@{$kohatables->{biblioitems}},@{$kohatables->{items}}) );
835 if( $f =~ /^'(.*)'.*/ ) {
836 # single quotes indicate a static text string.
839 } elsif ( $f =~ /^($match_kohatable).*/ ) {
840 # grep /$f/, (@$kohatables->{biblio},@$kohatables->{biblioitems},@$kohatables->{items}) ) {
841 $datastring .= $item->{$f};
843 } elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W*).*/ ) {
844 $datastring .= $record->subfield($1,$2) . $3 if($record->subfield($1,$2)) ;
847 last if ( $f eq $last_f ); # failed to match
853 Return a hashref of an array of hashes,
857 sub _descKohaTables {
858 my $dbh = C4::Context->dbh();
860 for my $table ( 'biblio','biblioitems','items' ) {
861 my $sth = $dbh->column_info(undef,undef,$table,'%');
862 while (my $info = $sth->fetchrow_hashref()){
863 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
870 sub GetPatronCardItems {
872 my ( $batch_id ) = @_;
875 my $dbh = C4::Context->dbh;
876 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
877 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
878 my $sth = $dbh->prepare($query);
879 $sth->execute($batch_id);
881 while ( my $data = $sth->fetchrow_hashref ) {
882 my $patron_data = GetMember( $data->{'borrowernumber'} );
883 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
884 $patron_data->{'cardno'} = $cardno;
885 $patron_data->{'cardid'} = $data->{'cardid'};
886 $patron_data->{'batch_id'} = $batch_id;
887 push( @resultsloop, $patron_data );
895 sub deduplicate_batch {
896 my ( $batch_id, $batch_type ) = @_;
899 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
900 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
903 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
907 my $sth = C4::Context->dbh->prepare($query);
908 $sth->execute($batch_id);
909 warn $sth->errstr if $sth->errstr;
910 $sth->rows or return undef, $sth->errstr;
916 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
917 ORDER BY timestamp ASC
920 while (my $data = $sth->fetchrow_hashref()) {
921 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
922 my $limit = $data->{count} - 1 or next;
923 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
924 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
925 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
926 $sth2->execute($batch_id, $itemnumber) and
927 $killed += ($data->{count} - 1);
928 warn $sth2->errstr if $sth2->errstr;
930 return $killed, undef;
935 my ( $ll, $wnl, $dec, $cutter, $pubdate);
939 # lccn example 'HE8700.7 .P6T44 1983';
942 ([0-9]+\.*[0-9]*) # 8700.7
944 (\.*[a-zA-Z0-9]*) # P6T44
949 # strip something occuring spaces too
950 $splits[0] =~ s/\s+$//;
951 $splits[1] =~ s/\s+$//;
952 $splits[2] =~ s/\s+$//;
954 # if the regex fails, then just return the whole string,
955 # better than nothing
956 # FIXME It seems we should handle all cases, have some graceful error handling, or at least inform the caller of the failure to split
957 $splits[0] = $lccn if $splits[0] eq '' ;
963 $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
965 # ddcn example R220.3 H2793Z H32 c.2
966 my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
967 ([0-9]+\.[0-9]*) # 220.3
968 \s? # space (not requiring anything beyond the call number)
969 ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
970 \s? # space if it exists
971 ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
972 \s? # space if ie exists
973 ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
980 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
981 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
983 # Replaced item's itemtype with the more user-friendly description...
984 my $dbh = C4::Context->dbh;
986 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
988 while ( my $data = $sth->fetchrow_hashref ) {
989 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
994 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
995 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.).
997 my $layout_id = $$conf_data->{'id'};
999 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1001 my @str_fields = get_text_fields($layout_id, 'codes' );
1002 my $record = GetMarcBiblio($$item->{biblionumber});
1003 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1004 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1006 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1007 my $cn_source = $$item->{'cn_source'};
1008 for my $field (@str_fields) {
1009 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1010 if ($$conf_data->{'formatstring'}) {
1011 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1013 $field->{data} = $$item->{$field->{'code'}} ;
1015 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1016 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1017 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1018 my $font = prFont($fontname);
1019 # if the display option for this field is selected in the DB,
1020 # and the item record has some values for this field, display it.
1021 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1023 my $str = $field->{data} ;
1024 # strip out naughty existing nl/cr's
1028 if ($field->{code} eq 'itemcallnumber' and $printingtype eq 'BIB') { # If the field contains the call number, we do some special processing on it here...
1029 if ($cn_source eq 'lcc') {
1030 @strings = split_lccn($str);
1031 } elsif ($cn_source eq 'ddc') {
1032 @strings = split_ddcn($str);
1034 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1035 push @strings, $str;
1038 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1039 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1040 $str =~ s/\)/\\\)/g;
1041 # Wrap text lines exceeding $text_wrap_cols length...
1042 $Text::Wrap::columns = $text_wrap_cols;
1043 my @line = split(/\n/ ,wrap('', '', $str));
1044 # If this is a title field, limit to two lines; all others limit to one...
1045 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1046 while (scalar(@line) > 2) {
1050 while (scalar(@line) > 1) {
1054 push(@strings, @line);
1056 # loop for each string line
1057 foreach my $str (@strings) {
1059 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
1060 # some code to try and center each line on the label based on font size and string point width...
1061 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1062 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1063 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1064 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1066 $hPos = ( $x_pos + $left_text_margin );
1068 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1069 $vPos = $vPos - $line_spacer;
1076 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1077 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1081 sub DrawPatronCardText {
1083 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1084 $text_wrap_cols, $text, $printingtype )
1087 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1089 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1090 my $font = prFont($fontname);
1094 foreach my $line (keys %$text) {
1095 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1096 # some code to try and center each line on the label based on font size and string point width...
1097 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1098 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1099 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1101 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1102 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.).
1103 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1107 # Not used anywhere.
1111 # my ($fontsize) = @_;
1113 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1119 # x and y are from the top-left :)
1120 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1121 my $num_of_bars = length($barcode);
1122 my $bar_width = $width * .8; # %80 of length of label width
1125 my $guard_length = 10;
1128 if ( $barcodetype eq 'CODE39' ) {
1129 $bar_length = '17.5';
1131 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1132 $xsize_ratio = ( $bar_width / $tot_bar_length );
1134 PDF::Reuse::Barcode::Code39(
1135 x => ( $x_pos + ( $width / 10 ) ),
1136 y => ( $y_pos + ( $height / 10 ) ),
1137 value => "*$barcode*",
1138 ySize => ( .02 * $height ),
1139 xSize => $xsize_ratio,
1144 warn "$barcodetype, $barcode FAILED:$@";
1148 elsif ( $barcodetype eq 'CODE39MOD' ) {
1150 # get modulo43 checksum
1151 my $c39 = CheckDigits('code_39');
1152 $barcode = $c39->complete($barcode);
1156 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1157 $xsize_ratio = ( $bar_width / $tot_bar_length );
1159 PDF::Reuse::Barcode::Code39(
1160 x => ( $x_pos + ( $width / 10 ) ),
1161 y => ( $y_pos + ( $height / 10 ) ),
1162 value => "*$barcode*",
1163 ySize => ( .02 * $height ),
1164 xSize => $xsize_ratio,
1170 warn "$barcodetype, $barcode FAILED:$@";
1173 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1175 # get modulo43 checksum
1176 my $c39_10 = CheckDigits('visa');
1177 $barcode = $c39_10->complete($barcode);
1181 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1182 $xsize_ratio = ( $bar_width / $tot_bar_length );
1184 PDF::Reuse::Barcode::Code39(
1185 x => ( $x_pos + ( $width / 10 ) ),
1186 y => ( $y_pos + ( $height / 10 ) ),
1187 value => "*$barcode*",
1188 ySize => ( .02 * $height ),
1189 xSize => $xsize_ratio,
1196 warn "$barcodetype, $barcode FAILED:$@";
1201 elsif ( $barcodetype eq 'COOP2OF5' ) {
1202 $bar_length = '9.43333333333333';
1204 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1205 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1207 PDF::Reuse::Barcode::COOP2of5(
1208 x => ( $x_pos + ( $width / 10 ) ),
1209 y => ( $y_pos + ( $height / 10 ) ),
1211 ySize => ( .02 * $height ),
1212 xSize => $xsize_ratio,
1216 warn "$barcodetype, $barcode FAILED:$@";
1220 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1221 $bar_length = '13.1333333333333';
1223 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1224 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1226 PDF::Reuse::Barcode::Industrial2of5(
1227 x => ( $x_pos + ( $width / 10 ) ),
1228 y => ( $y_pos + ( $height / 10 ) ),
1230 ySize => ( .02 * $height ),
1231 xSize => $xsize_ratio,
1235 warn "$barcodetype, $barcode FAILED:$@";
1239 my $moo2 = $tot_bar_length * $xsize_ratio;
1241 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1242 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1245 =item build_circ_barcode;
1247 build_circ_barcode( $x_pos, $y_pos, $barcode,
1248 $barcodetype, \$item);
1250 $item is the result of a previous call to GetLabelItems();
1255 sub build_circ_barcode {
1256 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1258 #warn Dumper \$item;
1260 #warn "value = $value\n";
1264 if ( $barcodetype eq 'EAN13' ) {
1266 #testing EAN13 barcodes hack
1267 $value = $value . '000000000';
1269 $value = substr( $value, 0, 12 );
1273 PDF::Reuse::Barcode::EAN13(
1274 x => ( $x_pos_circ + 27 ),
1275 y => ( $y_pos + 15 ),
1283 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1284 # i think its embedding extra fonts in the pdf file.
1285 # mode => 'graphic',
1289 $item->{'barcodeerror'} = 1;
1291 #warn "EAN13BARCODE FAILED:$@";
1297 elsif ( $barcodetype eq 'Code39' ) {
1300 PDF::Reuse::Barcode::Code39(
1301 x => ( $x_pos_circ + 9 ),
1302 y => ( $y_pos + 15 ),
1312 $item->{'barcodeerror'} = 1;
1314 #warn "CODE39BARCODE $value FAILED:$@";
1321 elsif ( $barcodetype eq 'Matrix2of5' ) {
1323 #warn "MATRIX ELSE:";
1325 #testing MATRIX25 barcodes hack
1326 # $value = $value.'000000000';
1329 # $value = substr( $value, 0, 12 );
1333 PDF::Reuse::Barcode::Matrix2of5(
1334 x => ( $x_pos_circ + 27 ),
1335 y => ( $y_pos + 15 ),
1345 $item->{'barcodeerror'} = 1;
1347 #warn "BARCODE FAILED:$@";
1354 elsif ( $barcodetype eq 'EAN8' ) {
1356 #testing ean8 barcodes hack
1357 $value = $value . '000000000';
1359 $value = substr( $value, 0, 8 );
1363 #warn "EAN8 ELSEIF";
1365 PDF::Reuse::Barcode::EAN8(
1366 x => ( $x_pos_circ + 42 ),
1367 y => ( $y_pos + 15 ),
1377 $item->{'barcodeerror'} = 1;
1379 #warn "BARCODE FAILED:$@";
1386 elsif ( $barcodetype eq 'UPC-E' ) {
1388 PDF::Reuse::Barcode::UPCE(
1389 x => ( $x_pos_circ + 27 ),
1390 y => ( $y_pos + 15 ),
1400 $item->{'barcodeerror'} = 1;
1402 #warn "BARCODE FAILED:$@";
1408 elsif ( $barcodetype eq 'NW7' ) {
1410 PDF::Reuse::Barcode::NW7(
1411 x => ( $x_pos_circ + 27 ),
1412 y => ( $y_pos + 15 ),
1422 $item->{'barcodeerror'} = 1;
1424 #warn "BARCODE FAILED:$@";
1430 elsif ( $barcodetype eq 'ITF' ) {
1432 PDF::Reuse::Barcode::ITF(
1433 x => ( $x_pos_circ + 27 ),
1434 y => ( $y_pos + 15 ),
1444 $item->{'barcodeerror'} = 1;
1446 #warn "BARCODE FAILED:$@";
1452 elsif ( $barcodetype eq 'Industrial2of5' ) {
1454 PDF::Reuse::Barcode::Industrial2of5(
1455 x => ( $x_pos_circ + 27 ),
1456 y => ( $y_pos + 15 ),
1465 $item->{'barcodeerror'} = 1;
1467 #warn "BARCODE FAILED:$@";
1473 elsif ( $barcodetype eq 'IATA2of5' ) {
1475 PDF::Reuse::Barcode::IATA2of5(
1476 x => ( $x_pos_circ + 27 ),
1477 y => ( $y_pos + 15 ),
1486 $item->{'barcodeerror'} = 1;
1488 #warn "BARCODE FAILED:$@";
1495 elsif ( $barcodetype eq 'COOP2of5' ) {
1497 PDF::Reuse::Barcode::COOP2of5(
1498 x => ( $x_pos_circ + 27 ),
1499 y => ( $y_pos + 15 ),
1508 $item->{'barcodeerror'} = 1;
1510 #warn "BARCODE FAILED:$@";
1516 elsif ( $barcodetype eq 'UPC-A' ) {
1519 PDF::Reuse::Barcode::UPCA(
1520 x => ( $x_pos_circ + 27 ),
1521 y => ( $y_pos + 15 ),
1530 $item->{'barcodeerror'} = 1;
1532 #warn "BARCODE FAILED:$@";
1541 =item draw_boundaries
1543 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1544 $y_pos, $spine_width, $label_height, $circ_width)
1546 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1551 sub draw_boundaries {
1554 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1555 $spine_width, $label_height, $circ_width
1558 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1559 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1562 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1564 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1566 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1567 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1568 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1570 $y_pos = ( $y_pos - $label_height );
1577 sub drawbox { $lower_left_x, $lower_left_y,
1578 $upper_right_x, $upper_right_y )
1580 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1582 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1584 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1590 my ( $llx, $lly, $urx, $ury ) = @_;
1592 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1594 my $str = "q\n"; # save the graphic state
1595 $str .= "0.5 w\n"; # border color red
1596 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1597 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1598 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1600 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1601 $str .= "B\n"; # fill (and a little more)
1602 $str .= "Q\n"; # save the graphic state
1608 END { } # module clean-up code here (global destructor)
1617 Mason James <mason@katipo.co.nz>