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
74 =item get_label_options;
76 $options = get_label_options()
78 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
82 sub get_label_options {
83 my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout
84 my $sth = C4::Context->dbh->prepare($query2);
86 return $sth->fetchrow_hashref;
90 my $dbh = C4::Context->dbh;
92 my $query = " Select * from labels_conf";
93 my $sth = $dbh->prepare($query);
96 while ( my $data = $sth->fetchrow_hashref ) {
98 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
99 push( @resultsloop, $data );
106 my ($layout_id) = @_;
107 my $dbh = C4::Context->dbh;
109 # get the actual items to be printed.
110 my $query = " Select * from labels_conf where id = ?";
111 my $sth = $dbh->prepare($query);
112 $sth->execute($layout_id);
113 my $data = $sth->fetchrow_hashref;
118 sub get_active_layout {
119 my $query = " Select * from labels_conf where active = 1"; # FIXME: exact same as get_label_options
120 my $sth = C4::Context->dbh->prepare($query);
122 return $sth->fetchrow_hashref;
126 my ($layout_id) = @_;
127 my $dbh = C4::Context->dbh;
129 # get the actual items to be printed.
130 my $query = "delete from labels_conf where id = ?";
131 my $sth = $dbh->prepare($query);
132 $sth->execute($layout_id);
136 sub get_printingtypes {
137 my ($layout_id) = @_;
139 # FIXME hard coded print types
140 push( @printtypes, { code => 'BAR', desc => "barcode only" } );
141 push( @printtypes, { code => 'BIB', desc => "biblio only" } );
142 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
143 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
144 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
145 push( @printtypes, { code => 'CSV', desc => "csv output" } );
146 push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
148 my $conf = get_layout($layout_id);
149 my $active_printtype = $conf->{'printingtype'};
151 # lop thru layout, insert selected to hash
153 foreach my $printtype (@printtypes) {
154 if ( $printtype->{'code'} eq $active_printtype ) {
155 $printtype->{'active'} = 1;
161 # this sub (build_text_dropbox) is deprecated and should be deleted.
164 sub build_text_dropbox {
166 my $field_count = 7; # <----------- FIXME hard coded
169 ? push( @lines, { num => '', selected => '1' } )
170 : push( @lines, { num => '' } );
171 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
172 my $line = { num => "$i" };
173 $line->{'selected'} = 1 if $i eq $order;
174 push( @lines, $line );
179 sub get_text_fields {
180 my ( $layout_id, $sorttype ) = @_;
183 my $sortorder = get_layout($layout_id);
184 if ( $sortorder->{formatstring} ) {
186 return $sortorder->{formatstring};
189 my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } );
190 my $line = $sortorder->{formatstring};
191 my $status = $csv->parse($line);
193 map { { 'code' => $_, desc => $_ } } $csv->fields();
194 $error = $csv->error_input();
195 warn $error if $error; # TODO - do more with this.
200 # These fields are hardcoded based on the template for label-edit-layout.pl
205 order => $sortorder->{'itemtype'}
210 order => $sortorder->{'issn'}
215 order => $sortorder->{'isbn'}
220 order => $sortorder->{'barcode'}
225 order => $sortorder->{'author'}
230 order => $sortorder->{'title'}
233 code => 'itemcallnumber',
234 desc => "Call Number",
235 order => $sortorder->{'itemcallnumber'}
240 foreach my $field (@text_fields) {
241 push( @new_fields, $field ) if $field->{'order'} > 0;
244 @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
247 # if we have a 'formatstring', then we ignore these hardcoded fields.
250 if ( $sorttype eq 'codes' )
251 { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit
252 return @sorted_fields;
255 foreach my $field (@sorted_fields) {
256 $active_fields .= "$field->{'desc'} ";
258 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.
272 sub add_batch ($;$) {
273 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
274 my $batch_list = (@_) ? shift : undef;
275 my $dbh = C4::Context->dbh;
276 my $q ="SELECT MAX(DISTINCT batch_id) FROM $table";
277 my $sth = $dbh->prepare($q);
279 my ($batch_id) = $sth->fetchrow_array || 0;
282 if ($table eq 'patroncards') {
283 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`borrowernumber`) VALUES (?,?)");
285 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`itemnumber` ) VALUES (?,?)");
288 $sth->execute($batch_id,$_);
294 #FIXME: Needs to be ported to receive $batch_type
295 # ... this looks eerily like add_batch() ...
296 sub get_highest_batch {
297 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
299 "select distinct batch_id from $table order by batch_id desc limit 1";
300 my $sth = C4::Context->dbh->prepare($q);
302 my $data = $sth->fetchrow_hashref or return 1;
303 return ($data->{'batch_id'} || 1);
307 sub get_batches (;$) {
308 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
309 my $q = "SELECT batch_id, COUNT(*) AS num FROM $table GROUP BY batch_id";
310 my $sth = C4::Context->dbh->prepare($q);
312 my $batches = $sth->fetchall_arrayref({});
317 my ($batch_id, $batch_type) = @_;
318 warn "Deleteing batch of type $batch_type";
319 my $dbh = C4::Context->dbh;
320 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
321 my $sth = $dbh->prepare($q);
322 $sth->execute($batch_id);
326 sub get_barcode_types {
327 my ($layout_id) = @_;
328 my $layout = get_layout($layout_id);
329 my $barcode = $layout->{'barcodetype'};
332 push( @array, { code => 'CODE39', desc => 'Code 39' } );
333 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
334 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
335 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
337 foreach my $line (@array) {
338 if ( $line->{'code'} eq $barcode ) {
339 $line->{'active'} = 1;
350 $unitvalue = '1' if ( $units eq 'POINT' );
351 $unitvalue = '2.83464567' if ( $units eq 'MM' );
352 $unitvalue = '28.3464567' if ( $units eq 'CM' );
353 $unitvalue = 72 if ( $units eq 'INCH' );
357 sub GetTextWrapCols {
358 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
362 # my $textlimit = $label_width - ($left_text_margin);
363 my $textlimit = $label_width - ( 3 * $left_text_margin);
365 while ( $strwidth < $textlimit ) {
366 $strwidth = prStrWidth( $string, $font, $fontsize );
367 $string = $string . '0';
368 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
374 sub GetActiveLabelTemplate {
375 my $dbh = C4::Context->dbh;
376 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
377 my $sth = $dbh->prepare($query);
379 my $active_tmpl = $sth->fetchrow_hashref;
384 sub GetSingleLabelTemplate {
386 my $dbh = C4::Context->dbh;
387 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
388 my $sth = $dbh->prepare($query);
389 $sth->execute($tmpl_id);
390 my $template = $sth->fetchrow_hashref;
395 sub SetActiveTemplate {
399 my $dbh = C4::Context->dbh;
400 my $query = " UPDATE labels_templates SET active = NULL";
401 my $sth = $dbh->prepare($query);
404 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
405 $sth = $dbh->prepare($query);
406 $sth->execute($tmpl_id);
410 sub set_active_layout {
412 my ($layout_id) = @_;
413 my $dbh = C4::Context->dbh;
414 my $query = " UPDATE labels_conf SET active = NULL";
415 my $sth = $dbh->prepare($query);
418 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
419 $sth = $dbh->prepare($query);
420 $sth->execute($layout_id);
426 my $dbh = C4::Context->dbh;
427 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
428 my $sth = $dbh->prepare($query);
429 $sth->execute($tmpl_id);
435 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
436 $page_height, $label_width, $label_height, $topmargin,
437 $leftmargin, $cols, $rows, $colgap,
438 $rowgap, $font, $fontsize, $units
440 $debug and warn "Passed \$font:$font";
441 my $dbh = C4::Context->dbh;
443 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
444 page_height=?, label_width=?, label_height=?, topmargin=?,
445 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
449 my $sth = $dbh->prepare($query);
451 $tmpl_code, $tmpl_desc, $page_width, $page_height,
452 $label_width, $label_height, $topmargin, $leftmargin,
453 $cols, $rows, $colgap, $rowgap,
454 $font, $fontsize, $units, $tmpl_id
456 my $dberror = $sth->errstr;
464 $tmpl_code, $tmpl_desc, $page_width, $page_height,
465 $label_width, $label_height, $topmargin, $leftmargin,
466 $cols, $rows, $colgap, $rowgap,
467 $font, $fontsize, $units
470 my $dbh = C4::Context->dbh;
472 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
473 page_height, label_width, label_height, topmargin,
474 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
475 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
477 my $sth = $dbh->prepare($query);
479 $tmpl_code, $tmpl_desc, $page_width, $page_height,
480 $label_width, $label_height, $topmargin, $leftmargin,
481 $cols, $rows, $colgap, $rowgap,
482 $font, $fontsize, $units
484 my $dberror = $sth->errstr;
489 sub GetAllLabelTemplates {
490 my $dbh = C4::Context->dbh;
492 # get the actual items to be printed.
494 my $query = " Select * from labels_templates ";
495 my $sth = $dbh->prepare($query);
498 while ( my $data = $sth->fetchrow_hashref ) {
499 push( @resultsloop, $data );
503 #warn Dumper @resultsloop;
511 $barcodetype, $title, $subtitle, $isbn, $issn,
512 $itemtype, $bcn, $dcn, $classif,
513 $subclass, $itemcallnumber, $author, $tmpl_id,
514 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
517 my $dbh = C4::Context->dbh;
518 my $query2 = "update labels_conf set active = NULL";
519 my $sth2 = $dbh->prepare($query2);
521 $query2 = "INSERT INTO labels_conf
522 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
523 dewey, classification, subclass, itemcallnumber, author, printingtype,
524 guidebox, startlabel, layoutname, formatstring, active )
525 values ( ?, ?,?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
526 $sth2 = $dbh->prepare($query2);
528 $barcodetype, $title, $subtitle, $isbn, $issn,
530 $itemtype, $bcn, $dcn, $classif,
531 $subclass, $itemcallnumber, $author, $printingtype,
532 $guidebox, $startlabel, $layoutname, $formatstring
536 SetActiveTemplate($tmpl_id);
543 $barcodetype, $title, $subtitle, $isbn, $issn,
544 $itemtype, $bcn, $dcn, $classif,
545 $subclass, $itemcallnumber, $author, $tmpl_id,
546 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
552 my $dbh = C4::Context->dbh;
553 my $query2 = "update labels_conf set
554 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
555 itemtype=?, barcode=?, dewey=?, classification=?,
556 subclass=?, itemcallnumber=?, author=?, printingtype=?,
557 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
558 my $sth2 = $dbh->prepare($query2);
560 $barcodetype, $title, $subtitle, $isbn, $issn,
561 $itemtype, $bcn, $dcn, $classif,
562 $subclass, $itemcallnumber, $author, $printingtype,
563 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
570 =item GetAllPrinterProfiles;
572 @profiles = GetAllPrinterProfiles()
574 Returns an array of references-to-hash, whos keys are .....
578 sub GetAllPrinterProfiles {
580 my $dbh = C4::Context->dbh;
582 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
583 my $sth = $dbh->prepare($query);
586 while ( my $data = $sth->fetchrow_hashref ) {
587 push( @resultsloop, $data );
594 =item GetSinglePrinterProfile;
596 $profile = GetSinglePrinterProfile()
598 Returns a hashref whos keys are...
602 sub GetSinglePrinterProfile {
604 my $dbh = C4::Context->dbh;
605 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
606 my $sth = $dbh->prepare($query);
607 $sth->execute($prof_id);
608 my $template = $sth->fetchrow_hashref;
615 SaveProfile('parameters')
617 When passed a set of parameters, this function updates the given profile with the new parameters.
623 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
625 my $dbh = C4::Context->dbh;
627 " UPDATE printers_profile
628 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
630 my $sth = $dbh->prepare($query);
632 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
639 CreateProfile('parameters')
641 When passed a set of parameters, this function creates a new profile containing those parameters
642 and returns any errors.
648 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
649 $offset_vert, $creep_horz, $creep_vert, $units
651 my $dbh = C4::Context->dbh;
653 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
654 offset_horz, offset_vert, creep_horz, creep_vert, unit)
655 VALUES(?,?,?,?,?,?,?,?,?) ";
656 my $sth = $dbh->prepare($query);
658 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
659 $offset_vert, $creep_horz, $creep_vert, $units
661 my $error = $sth->errstr;
668 DeleteProfile(prof_id)
670 When passed a profile id, this function deletes that profile from the database and returns any errors.
676 my $dbh = C4::Context->dbh;
677 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
678 my $sth = $dbh->prepare($query);
679 $sth->execute($prof_id);
680 my $error = $sth->errstr;
685 =item GetAssociatedProfile;
687 $assoc_prof = GetAssociatedProfile(tmpl_id)
689 When passed a template id, this function returns the parameters from the currently associated printer profile
690 in a hashref where key=fieldname and value=fieldvalue.
694 sub GetAssociatedProfile {
696 my $dbh = C4::Context->dbh;
697 # First we find out the prof_id for the associated profile...
698 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
699 my $sth = $dbh->prepare($query);
700 $sth->execute($tmpl_id);
701 my $assoc_prof = $sth->fetchrow_hashref;
703 # Then we retrieve that profile and return it to the caller...
704 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
708 =item SetAssociatedProfile;
710 SetAssociatedProfile($prof_id, $tmpl_id)
712 When passed both a profile id and template id, this function establishes an association between the two. No more
713 than one profile may be associated with any given template at the same time.
717 sub SetAssociatedProfile {
719 my ($prof_id, $tmpl_id) = @_;
721 my $dbh = C4::Context->dbh;
722 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
723 my $sth = $dbh->prepare($query);
724 $sth->execute($prof_id, $tmpl_id, $prof_id);
731 $options = GetLabelItems()
733 Returns an array of references-to-hash, whos keys are the fields from the biblio, biblioitems, items and labels tables in the Koha database.
739 my $dbh = C4::Context->dbh;
741 my @resultsloop = ();
752 $sth = $dbh->prepare($query3);
753 $sth->execute($batch_id);
759 $sth = $dbh->prepare($query3);
762 my $cnt = $sth->rows;
764 while ( my $data = $sth->fetchrow_hashref ) {
766 # lets get some summary info from each item
768 # FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten...
769 # SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
770 "SELECT i.*, bi.*, b.*
771 FROM items AS i, biblioitems AS bi ,biblio AS b
772 WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber";
773 my $sth1 = $dbh->prepare($query1);
774 $sth1->execute( $data->{'itemnumber'} );
776 my $data1 = $sth1->fetchrow_hashref();
777 $data1->{'labelno'} = $i1;
778 $data1->{'labelid'} = $data->{'labelid'};
779 $data1->{'batch_id'} = $batch_id;
780 $data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
782 push( @resultsloop, $data1 );
805 Parse labels_conf.formatstring value
806 (one value of the csv, which has already been split)
807 and return string from koha tables or MARC record.
812 my ( $f, $item, $record ) = @_;
813 my $kohatables = &_descKohaTables();
815 my $match_kohatable = join(
818 @{ $kohatables->{biblio} },
819 @{ $kohatables->{biblioitems} },
820 @{ $kohatables->{items} }
825 if ( $f =~ /^'(.*)'.*/ ) {
826 # single quotes indicate a static text string.
830 elsif ( $f =~ /^($match_kohatable).*/ ) {
831 $datastring .= $item->{$f};
834 elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
836 foreach my $subfield ($record->field($marc_field)) {
837 if ( $subfield->subfield('9') eq $item->{'itemnumber'} ) {
838 $datastring .= $subfield->subfield($2 ) . $3;
845 last; # Failed to match
852 Return a hashref of an array of hashes,
856 sub _descKohaTables {
857 my $dbh = C4::Context->dbh();
859 for my $table ( 'biblio','biblioitems','items' ) {
860 my $sth = $dbh->column_info(undef,undef,$table,'%');
861 while (my $info = $sth->fetchrow_hashref()){
862 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
869 sub GetPatronCardItems {
871 my ( $batch_id ) = @_;
874 my $dbh = C4::Context->dbh;
875 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
876 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
877 my $sth = $dbh->prepare($query);
878 $sth->execute($batch_id);
880 while ( my $data = $sth->fetchrow_hashref ) {
881 my $patron_data = GetMember( $data->{'borrowernumber'} );
882 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
883 $patron_data->{'cardno'} = $cardno;
884 $patron_data->{'cardid'} = $data->{'cardid'};
885 $patron_data->{'batch_id'} = $batch_id;
886 push( @resultsloop, $patron_data );
894 sub deduplicate_batch {
895 my ( $batch_id, $batch_type ) = @_;
898 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
899 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
902 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
906 my $sth = C4::Context->dbh->prepare($query);
907 $sth->execute($batch_id);
908 warn $sth->errstr if $sth->errstr;
909 $sth->rows or return undef, $sth->errstr;
915 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
916 ORDER BY timestamp ASC
919 while (my $data = $sth->fetchrow_hashref()) {
920 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
921 my $limit = $data->{count} - 1 or next;
922 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
923 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
924 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
925 $sth2->execute($batch_id, $itemnumber) and
926 $killed += ($data->{count} - 1);
927 warn $sth2->errstr if $sth2->errstr;
929 return $killed, undef;
934 my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
936 # lccn example 'HE8700.7 .P6T44 1983';
939 ([0-9]+\.*[0-9]*) # 8700.7
941 (\.*[a-zA-Z0-9]*) # P6T44
946 # strip something occuring spaces too
947 $splits[0] =~ s/\s+$//;
948 $splits[1] =~ s/\s+$//;
949 $splits[2] =~ s/\s+$//;
951 # if the regex fails, then just return the whole string,
952 # better than nothing
953 # FIXME It seems we should handle all cases, have some graceful error handling, or at least inform the caller of the failure to split
954 $splits[0] = $lccn if $splits[0] eq '' ;
960 $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
962 # ddcn example R220.3 H2793Z H32 c.2
963 my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
964 ([0-9]+\.[0-9]*) # 220.3
965 \s? # space (not requiring anything beyond the call number)
966 ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
967 \s? # space if it exists
968 ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
969 \s? # space if ie exists
970 ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
977 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
978 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
980 # Replaced item's itemtype with the more user-friendly description...
981 my $dbh = C4::Context->dbh;
982 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
984 while ( my $data = $sth->fetchrow_hashref ) {
985 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
986 $$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
991 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
992 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.).
994 my $layout_id = $$conf_data->{'id'};
996 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
998 my @str_fields = get_text_fields($layout_id, 'codes' );
999 my $record = GetMarcBiblio($$item->{biblionumber});
1000 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1001 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1003 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1004 my $cn_source = $record->subfield('952','2');
1005 for my $field (@str_fields) {
1006 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1007 if ($$conf_data->{'formatstring'}) {
1008 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1010 elsif ($field->{'code'} eq 'itemtype') {
1011 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1014 $field->{data} = $$item->{$field->{'code'}} ;
1016 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1017 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1018 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1019 my $font = prFont($fontname);
1020 # if the display option for this field is selected in the DB,
1021 # and the item record has some values for this field, display it.
1022 # Or if there is a csv list of fields to display, display them.
1023 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1025 my $str = $field->{data} ;
1026 # strip out naughty existing nl/cr's
1030 my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data
1031 if ((grep {$field->{code} =~ m/$_/} @callnumber_list) and ($printingtype eq 'BIB')) { # If the field contains the call number, we do some sp
1032 if ($cn_source eq 'lcc') {
1033 @strings = split_lccn($str);
1034 } elsif ($cn_source eq 'ddc') {
1035 @strings = split_ddcn($str);
1037 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1038 push @strings, $str;
1041 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1042 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1043 $str =~ s/\)/\\\)/g;
1044 # Wrap text lines exceeding $text_wrap_cols length...
1045 $Text::Wrap::columns = $text_wrap_cols;
1046 my @line = split(/\n/ ,wrap('', '', $str));
1047 # If this is a title field, limit to two lines; all others limit to one...
1048 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1049 while (scalar(@line) > 2) {
1053 while (scalar(@line) > 1) {
1057 push(@strings, @line);
1059 # loop for each string line
1060 foreach my $str (@strings) {
1062 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
1063 # some code to try and center each line on the label based on font size and string point width...
1064 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1065 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1066 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1067 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1069 $hPos = ( $x_pos + $left_text_margin );
1071 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1072 $vPos = $vPos - $line_spacer;
1079 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1080 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1084 sub DrawPatronCardText {
1086 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1087 $text_wrap_cols, $text, $printingtype )
1090 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1092 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1093 my $font = prFont($fontname);
1097 foreach my $line (keys %$text) {
1098 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1099 # some code to try and center each line on the label based on font size and string point width...
1100 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1101 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1102 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1104 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1105 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.).
1106 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1110 # Not used anywhere.
1114 # my ($fontsize) = @_;
1116 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1122 # x and y are from the top-left :)
1123 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1124 my $num_of_bars = length($barcode);
1125 my $bar_width = $width * .8; # %80 of length of label width
1126 my $tot_bar_length = 0;
1128 my $guard_length = 10;
1129 my $xsize_ratio = 0;
1131 if ( $barcodetype eq 'CODE39' ) {
1132 $bar_length = '17.5';
1134 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1135 $xsize_ratio = ( $bar_width / $tot_bar_length );
1137 PDF::Reuse::Barcode::Code39(
1138 x => ( $x_pos + ( $width / 10 ) ),
1139 y => ( $y_pos + ( $height / 10 ) ),
1140 value => "*$barcode*",
1141 ySize => ( .02 * $height ),
1142 xSize => $xsize_ratio,
1147 warn "$barcodetype, $barcode FAILED:$@";
1151 elsif ( $barcodetype eq 'CODE39MOD' ) {
1153 # get modulo43 checksum
1154 my $c39 = CheckDigits('code_39');
1155 $barcode = $c39->complete($barcode);
1159 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1160 $xsize_ratio = ( $bar_width / $tot_bar_length );
1162 PDF::Reuse::Barcode::Code39(
1163 x => ( $x_pos + ( $width / 10 ) ),
1164 y => ( $y_pos + ( $height / 10 ) ),
1165 value => "*$barcode*",
1166 ySize => ( .02 * $height ),
1167 xSize => $xsize_ratio,
1173 warn "$barcodetype, $barcode FAILED:$@";
1176 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1178 # get modulo43 checksum
1179 my $c39_10 = CheckDigits('visa');
1180 $barcode = $c39_10->complete($barcode);
1184 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1185 $xsize_ratio = ( $bar_width / $tot_bar_length );
1187 PDF::Reuse::Barcode::Code39(
1188 x => ( $x_pos + ( $width / 10 ) ),
1189 y => ( $y_pos + ( $height / 10 ) ),
1190 value => "*$barcode*",
1191 ySize => ( .02 * $height ),
1192 xSize => $xsize_ratio,
1199 warn "$barcodetype, $barcode FAILED:$@";
1204 elsif ( $barcodetype eq 'COOP2OF5' ) {
1205 $bar_length = '9.43333333333333';
1207 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1208 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1210 PDF::Reuse::Barcode::COOP2of5(
1211 x => ( $x_pos + ( $width / 10 ) ),
1212 y => ( $y_pos + ( $height / 10 ) ),
1214 ySize => ( .02 * $height ),
1215 xSize => $xsize_ratio,
1219 warn "$barcodetype, $barcode FAILED:$@";
1223 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1224 $bar_length = '13.1333333333333';
1226 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1227 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1229 PDF::Reuse::Barcode::Industrial2of5(
1230 x => ( $x_pos + ( $width / 10 ) ),
1231 y => ( $y_pos + ( $height / 10 ) ),
1233 ySize => ( .02 * $height ),
1234 xSize => $xsize_ratio,
1238 warn "$barcodetype, $barcode FAILED:$@";
1242 my $moo2 = $tot_bar_length * $xsize_ratio;
1244 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1245 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1248 =item build_circ_barcode;
1250 build_circ_barcode( $x_pos, $y_pos, $barcode,
1251 $barcodetype, \$item);
1253 $item is the result of a previous call to GetLabelItems();
1258 sub build_circ_barcode {
1259 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1261 #warn Dumper \$item;
1263 #warn "value = $value\n";
1267 if ( $barcodetype eq 'EAN13' ) {
1269 #testing EAN13 barcodes hack
1270 $value = $value . '000000000';
1272 $value = substr( $value, 0, 12 );
1276 PDF::Reuse::Barcode::EAN13(
1277 x => ( $x_pos_circ + 27 ),
1278 y => ( $y_pos + 15 ),
1286 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1287 # i think its embedding extra fonts in the pdf file.
1288 # mode => 'graphic',
1292 $item->{'barcodeerror'} = 1;
1294 #warn "EAN13BARCODE FAILED:$@";
1300 elsif ( $barcodetype eq 'Code39' ) {
1303 PDF::Reuse::Barcode::Code39(
1304 x => ( $x_pos_circ + 9 ),
1305 y => ( $y_pos + 15 ),
1315 $item->{'barcodeerror'} = 1;
1317 #warn "CODE39BARCODE $value FAILED:$@";
1324 elsif ( $barcodetype eq 'Matrix2of5' ) {
1326 #warn "MATRIX ELSE:";
1328 #testing MATRIX25 barcodes hack
1329 # $value = $value.'000000000';
1332 # $value = substr( $value, 0, 12 );
1336 PDF::Reuse::Barcode::Matrix2of5(
1337 x => ( $x_pos_circ + 27 ),
1338 y => ( $y_pos + 15 ),
1348 $item->{'barcodeerror'} = 1;
1350 #warn "BARCODE FAILED:$@";
1357 elsif ( $barcodetype eq 'EAN8' ) {
1359 #testing ean8 barcodes hack
1360 $value = $value . '000000000';
1362 $value = substr( $value, 0, 8 );
1366 #warn "EAN8 ELSEIF";
1368 PDF::Reuse::Barcode::EAN8(
1369 x => ( $x_pos_circ + 42 ),
1370 y => ( $y_pos + 15 ),
1380 $item->{'barcodeerror'} = 1;
1382 #warn "BARCODE FAILED:$@";
1389 elsif ( $barcodetype eq 'UPC-E' ) {
1391 PDF::Reuse::Barcode::UPCE(
1392 x => ( $x_pos_circ + 27 ),
1393 y => ( $y_pos + 15 ),
1403 $item->{'barcodeerror'} = 1;
1405 #warn "BARCODE FAILED:$@";
1411 elsif ( $barcodetype eq 'NW7' ) {
1413 PDF::Reuse::Barcode::NW7(
1414 x => ( $x_pos_circ + 27 ),
1415 y => ( $y_pos + 15 ),
1425 $item->{'barcodeerror'} = 1;
1427 #warn "BARCODE FAILED:$@";
1433 elsif ( $barcodetype eq 'ITF' ) {
1435 PDF::Reuse::Barcode::ITF(
1436 x => ( $x_pos_circ + 27 ),
1437 y => ( $y_pos + 15 ),
1447 $item->{'barcodeerror'} = 1;
1449 #warn "BARCODE FAILED:$@";
1455 elsif ( $barcodetype eq 'Industrial2of5' ) {
1457 PDF::Reuse::Barcode::Industrial2of5(
1458 x => ( $x_pos_circ + 27 ),
1459 y => ( $y_pos + 15 ),
1468 $item->{'barcodeerror'} = 1;
1470 #warn "BARCODE FAILED:$@";
1476 elsif ( $barcodetype eq 'IATA2of5' ) {
1478 PDF::Reuse::Barcode::IATA2of5(
1479 x => ( $x_pos_circ + 27 ),
1480 y => ( $y_pos + 15 ),
1489 $item->{'barcodeerror'} = 1;
1491 #warn "BARCODE FAILED:$@";
1498 elsif ( $barcodetype eq 'COOP2of5' ) {
1500 PDF::Reuse::Barcode::COOP2of5(
1501 x => ( $x_pos_circ + 27 ),
1502 y => ( $y_pos + 15 ),
1511 $item->{'barcodeerror'} = 1;
1513 #warn "BARCODE FAILED:$@";
1519 elsif ( $barcodetype eq 'UPC-A' ) {
1522 PDF::Reuse::Barcode::UPCA(
1523 x => ( $x_pos_circ + 27 ),
1524 y => ( $y_pos + 15 ),
1533 $item->{'barcodeerror'} = 1;
1535 #warn "BARCODE FAILED:$@";
1544 =item draw_boundaries
1546 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1547 $y_pos, $spine_width, $label_height, $circ_width)
1549 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1554 sub draw_boundaries {
1557 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1558 $spine_width, $label_height, $circ_width
1561 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1562 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1565 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1567 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1569 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1570 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1571 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1573 $y_pos = ( $y_pos - $label_height );
1580 sub drawbox { $lower_left_x, $lower_left_y,
1581 $upper_right_x, $upper_right_y )
1583 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1585 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1587 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1593 my ( $llx, $lly, $urx, $ury ) = @_;
1595 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1597 my $str = "q\n"; # save the graphic state
1598 $str .= "0.5 w\n"; # border color red
1599 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1600 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1601 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1603 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1604 $str .= "B\n"; # fill (and a little more)
1605 $str .= "Q\n"; # save the graphic state
1611 END { } # module clean-up code here (global destructor)
1620 Mason James <mason@katipo.co.nz>