C4/Labels/Label.pm

   1 package C4::Labels::Label;
   2
   3 # Copyright 2006 Katipo Communications.
   4 # Some parts Copyright 2009 Foundations Bible College.
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 2 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along with
  18 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  19 # Suite 330, Boston, MA  02111-1307 USA
  20
  21 use strict;
  22 use warnings;
  23
  24 use Sys::Syslog qw(syslog);
  25 use Text::Wrap;
  26 use Algorithm::CheckDigits;
  27 use Text::CSV_XS;
  28
  29 use C4::Context;
  30 use C4::Debug;
  31 use C4::Biblio;
  32 use Data::Dumper;
  33
  34 BEGIN {
  35     use version; our $VERSION = qv('1.0.0_1');
  36 }
  37
  38 sub _guide_box {
  39     my ( $llx, $lly, $width, $height ) = @_;
  40     my $obj_stream = "q\n";                            # save the graphic state
  41     $obj_stream .= "0.5 w\n";                          # border line width
  42     $obj_stream .= "1.0 0.0 0.0  RG\n";                # border color red
  43     $obj_stream .= "1.0 1.0 1.0  rg\n";                # fill color white
  44     $obj_stream .= "$llx $lly $width $height re\n";    # a rectangle
  45     $obj_stream .= "B\n";                              # fill (and a little more)
  46     $obj_stream .= "Q\n";                              # restore the graphic state
  47     return $obj_stream;
  48 }
  49
  50 sub _get_label_item {
  51     my $item_number = shift;
  52     my $barcode_only = shift || 0;
  53     my $dbh = C4::Context->dbh;
  54     my $query =
  55 #        FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten.
  56 #        Something like this, perhaps, but this also causes problems because we need more fields sometimes.
  57 #        SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
  58        "SELECT bi.*, i.*, b.*
  59         FROM items AS i, biblioitems AS bi ,biblio AS b
  60         WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber";
  61     my $sth = $dbh->prepare($query);
  62     $sth->execute($item_number);
  63     if ($sth->err) {
  64         syslog("LOG_ERR", "C4::Labels::Label::_get_label_item : Database returned the following error: %s", $sth->errstr);
  65     }
  66     my $data = $sth->fetchrow_hashref;
  67     # Replaced item's itemtype with the more user-friendly description...
  68     my $sth1 = $dbh->prepare("SELECT itemtype,description FROM itemtypes WHERE itemtype = ?");
  69     $sth1->execute($data->{'itemtype'});
  70     if ($sth1->err) {
  71         syslog("LOG_ERR", "C4::Labels::Label::_get_label_item : Database returned the following error: %s", $sth1->errstr);
  72     }
  73     my $data1 = $sth->fetchrow_hashref;
  74     $data->{'itemtype'} = $data1->{'description'};
  75     $data->{'itype'} = $data1->{'description'};
  76     $barcode_only ? return $data->{'barcode'} : return $data;
  77 }
  78
  79 sub _get_text_fields {
  80     my $format_string = shift;
  81     my $csv = Text::CSV_XS->new({allow_whitespace => 1});
  82     my $status = $csv->parse($format_string);
  83     my @sorted_fields = map {{ 'code' => $_, desc => $_ }} $csv->fields();
  84     my $error = $csv->error_input();
  85     syslog("LOG_ERR", "C4::Labels::Label::_get_text_fields : Text field sort failed with this error: %s", $error) if $error;
  86     return \@sorted_fields;
  87 }
  88
  89 sub _split_lccn {
  90     my ($lccn) = @_;
  91     my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
  92     $_ = $lccn;
  93     # lccn example 'HE8700.7 .P6T44 1983';
  94     my    @splits   = m/
  95         (^[a-zA-Z]+)            # HE
  96         ([0-9]+\.*[0-9]*)             # 8700.7
  97         \s*
  98         (\.*[a-zA-Z0-9]*)       # P6T44
  99         \s*
 100         ([0-9]*)                # 1983
 101         /x;
 102
 103     # strip something occuring spaces too
 104     $splits[0] =~ s/\s+$//;
 105     $splits[1] =~ s/\s+$//;
 106     $splits[2] =~ s/\s+$//;
 107
 108     return @splits;
 109 }
 110
 111 sub _split_ddcn {
 112     my ($ddcn) = @_;
 113     $ddcn =~ s/\///g;   # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
 114     $_ = $ddcn;
 115     # ddcn example R220.3 H2793Z H32 c.2
 116     my @splits = m/^([A-Z]{0,3})                # R (OS, REF, etc. up do three letters)
 117                     ([0-9]+\.[0-9]*)            # 220.3
 118                     \s?                         # space (not requiring anything beyond the call number)
 119                     ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
 120                     \s?                         # space if it exists
 121                     ([a-zA-Z]*\.?[0-9]*)        # other indicators such as cutter for author of literary criticism in this example if it exists
 122                     \s?                         # space if ie exists
 123                     ([a-zA-Z]*\.?[0-9]*)        # other indicators such as volume number, copy number, edition date, etc. if it exists
 124                     /x;
 125     return @splits;
 126 }
 127
 128 sub _split_fcn {
 129     my ($fcn) = @_;
 130     my @fcn_split = ();
 131     # Split fiction call numbers based on spaces
 132     SPLIT_FCN:
 133     while ($fcn) {
 134         if ($fcn =~ m/([A-Za-z0-9]+\.?[0-9]?)(\W?).*?/x) {
 135             push (@fcn_split, $1);
 136             $fcn = $';
 137         }
 138         else {
 139             last SPLIT_FCN;     # No match, break out of the loop
 140         }
 141     }
 142     return @fcn_split;
 143 }
 144
 145 sub _get_fields {
 146     my ( $layout_id, $sorttype ) = @_;
 147     my @sorted_fields;
 148     my $sortorder = get_layout($layout_id);
 149     if ( !$sorttype ) {
 150         return $sortorder->{'formatstring'};
 151     }
 152     else {
 153         my $csv    = Text::CSV_XS->new( { allow_whitespace => 1 } );
 154         my $line   = $sortorder->{'formatstring'};
 155         my $status = $csv->parse($line);
 156         @sorted_fields =
 157           map { { 'code' => $_, desc => $_ } } $csv->fields();
 158         if (my $error = $csv->error_input()) {
 159             syslog("LOG_ERR", "C4::Labels::Label::_get_fields : Text::CSV_XS returned the following error: %s", $error);
 160         }
 161     }
 162 }
 163
 164 sub _get_item_fields {
 165     my @fields = qw (
 166       barcode           title
 167       isbn              issn
 168       author            itemtype
 169       itemcallnumber
 170     );
 171     return @fields;
 172 }
 173
 174 sub _get_barcode_data {
 175     my ( $f, $item, $record ) = @_;
 176     my $kohatables = _desc_koha_tables();
 177     my $datastring = '';
 178     my $match_kohatable = join(
 179         '|',
 180         (
 181             @{ $kohatables->{'biblio'} },
 182             @{ $kohatables->{'biblioitems'} },
 183             @{ $kohatables->{'items'} }
 184         )
 185     );
 186     FIELD_LIST:
 187     while ($f) {
 188         my $err = '';
 189         $f =~ s/^\s?//;
 190         if ( $f =~ /^'(.*)'.*/ ) {
 191             # single quotes indicate a static text string.
 192             $datastring .= $1;
 193             $f = $';
 194             next FIELD_LIST;
 195         }
 196         elsif ( $f =~ /^($match_kohatable).*/ ) {
 197             if ($item->{$f}) {
 198                 $datastring .= $item->{$f};
 199             }
 200             else {
 201                 syslog("LOG_ERR", "C4::Labels::Label::_get_barcode_data : The '%s' field contains no data.", $f);
 202             }
 203             $f = $';
 204             next FIELD_LIST;
 205         }
 206         elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
 207             my ($field,$subf,$ws) = ($1,$2,$3);
 208             my $subf_data;
 209             my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
 210             my @marcfield = $record->field($field);
 211             if(@marcfield) {
 212                 if($field eq $itemtag) {  # item-level data, we need to get the right item.
 213                     ITEM_FIELDS:
 214                     foreach my $itemfield (@marcfield) {
 215                         if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
 216                             if ($itemfield->subfield($subf)) {
 217                                 $datastring .= $itemfield->subfield($subf) . $ws;
 218                             }
 219                             else {
 220                                 syslog("LOG_ERR", "C4::Labels::Label::_get_barcode_data : The '%s' field contains no data.", $f);
 221                             }
 222                             last ITEM_FIELDS;
 223                         }
 224                     }
 225                 } else {  # bib-level data, we'll take the first matching tag/subfield.
 226                     if ($marcfield[0]->subfield($subf)) {
 227                         $datastring .= $marcfield[0]->subfield($subf) . $ws;
 228                     }
 229                     else {
 230                         syslog("LOG_ERR", "C4::Labels::Label::_get_barcode_data : The '%s' field contains no data.", $f);
 231                     }
 232                 }
 233             }
 234             $f = $';
 235             next FIELD_LIST;
 236         }
 237         else {
 238             syslog("LOG_ERR", "C4::Labels::Label::_get_barcode_data : Failed to parse label format string: %s", $f);
 239             last FIELD_LIST;    # Failed to match
 240         }
 241     }
 242     return $datastring;
 243 }
 244
 245 sub _desc_koha_tables {
 246         my $dbh = C4::Context->dbh();
 247         my $kohatables;
 248         for my $table ( 'biblio','biblioitems','items' ) {
 249                 my $sth = $dbh->column_info(undef,undef,$table,'%');
 250                 while (my $info = $sth->fetchrow_hashref()){
 251                         push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
 252                 }
 253                 $sth->finish;
 254         }
 255         return $kohatables;
 256 }
 257
 258 sub new {
 259     my ($invocant, %params) = @_;
 260     my $type = ref($invocant) || $invocant;
 261     my $self = {
 262         batch_id                => $params{'batch_id'},
 263         item_number             => $params{'item_number'},
 264         height                  => $params{'height'},
 265         width                   => $params{'width'},
 266         top_text_margin         => $params{'top_text_margin'},
 267         left_text_margin        => $params{'left_text_margin'},
 268         barcode_type            => $params{'barcode_type'},
 269         printing_type           => $params{'printing_type'},
 270         guidebox                => $params{'guidebox'},
 271         font                    => $params{'font'},
 272         font_size               => $params{'font_size'},
 273         callnum_split           => $params{'callnum_split'},
 274         justify                 => $params{'justify'},
 275         format_string           => $params{'format_string'},
 276         text_wrap_cols          => $params{'text_wrap_cols'},
 277         barcode                 => 0,
 278     };
 279     if ($self->{'guidebox'}) {
 280         $self->{'guidebox'} = _guide_box($self->{'llx'}, $self->{'lly'}, $self->{'width'}, $self->{'height'});
 281     }
 282     bless ($self, $type);
 283     return $self;
 284 }
 285
 286 sub get_label_type {
 287     my $self = shift;
 288     return $self->{'printing_type'};
 289 }
 290
 291 =head2 $label->get_attr("attr")
 292
 293     Invoking the I<get_attr> method will return the value of the requested attribute or 1 on errors.
 294
 295     example:
 296         my $value = $label->get_attr("attr");
 297
 298 =cut
 299
 300 sub get_attr {
 301     my $self = shift;
 302 #    if (_check_params(@_) eq 1) {
 303 #        return -1;
 304 #    }
 305     my ($attr) = @_;
 306     if (exists($self->{$attr})) {
 307         return $self->{$attr};
 308     }
 309     else {
 310         return -1;
 311     }
 312     return;
 313 }
 314
 315 =head2 $label->draw_label_text()
 316
 317     Invoking the I<draw_label_text> method generates the label text for the label object.
 318     example:
 319        $label->draw_label_text(
 320                     llx                 => $text_llx,
 321                     lly                 => $text_lly,
 322                     top_text_margin     => $label_top_text_margin,
 323                     line_spacer         => $text_leading,
 324                     font                => $text_font,
 325                     font_size           => $text_font_size,
 326                     justify             => $text_justification,
 327         );
 328 =cut
 329
 330 sub draw_label_text {
 331     my ($self, %params) = @_;
 332     my @label_text = ();
 333     my $text_llx = 0;
 334     my $text_lly = $params{'lly'};
 335     my $font = $self->{'font'};
 336     my $item = _get_label_item($self->{'item_number'});
 337     my $label_fields = _get_text_fields($self->{'format_string'});
 338     my $record = GetMarcBiblio($item->{'biblionumber'});
 339     # FIXME - returns all items, so you can't get data from an embedded holdings field.
 340     # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
 341     my $cn_source = ($item->{'cn_source'} ? $item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
 342     LABEL_FIELDS:       # process data for requested fields on current label
 343     for my $field (@$label_fields) {
 344         if ($field->{'code'} eq 'itemtype') {
 345             $field->{'data'} = C4::Context->preference('item-level_itypes') ? $item->{'itype'} : $item->{'itemtype'};
 346         }
 347         else {
 348             $field->{'data'} = _get_barcode_data($field->{'code'},$item,$record);
 349         }
 350         ($field->{'code'} eq 'title') ? (($font =~ /T/) ? ($font = 'TI') : ($font = ($font . 'O'))) : ($font = $font);
 351         my $field_data = $field->{'data'};
 352         $field_data =~ s/\n//g;
 353         $field_data =~ s/\r//g;
 354         my @label_lines;
 355         my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data  FIXME: ( 060? 090? 092? 099? )
 356         if ((grep {$field->{'code'} =~ m/$_/} @callnumber_list) and ($self->{'printing_type'} eq 'BIB') and ($self->{'callnum_split'})) { # If the field contains the call number, we do some sp
 357             if ($cn_source eq 'lcc') {
 358                 @label_lines = _split_lccn($field_data);
 359                 @label_lines = _split_fcn($field_data) if !@label_lines;    # If it was not a true lccn, try it as a fiction call number
 360                 push (@label_lines, $field_data) if !@label_lines;         # If it was not that, send it on unsplit
 361             } elsif ($cn_source eq 'ddc') {
 362                 @label_lines = _split_ddcn($field_data);
 363                 @label_lines = _split_fcn($field_data) if !@label_lines;
 364                 push (@label_lines, $field_data) if !@label_lines;
 365             } else {
 366                 syslog("LOG_ERR", "C4::Labels::Label->draw_label_text : Call number splitting failed for: %s. Please add this call number to bug #2500 at bugs.koha.org", $field_data);
 367                 push @label_lines, $field_data;
 368             }
 369         }
 370         else {
 371             $field_data =~ s/\/$//g;       # Here we will strip out all trailing '/' in fields other than the call number...
 372             $field_data =~ s/\(/\\\(/g;    # Escape '(' and ')' for the pdf object stream...
 373             $field_data =~ s/\)/\\\)/g;
 374             eval{local($Text::Wrap::columns) = $self->{'text_wrap_cols'};};
 375             my @line = split(/\n/ ,wrap('', '', $field_data));
 376             # If this is a title field, limit to two lines; all others limit to one... FIXME: this is rather arbitrary
 377             if ($field->{'code'} eq 'title' && scalar(@line) >= 2) {
 378                 while (scalar(@line) > 2) {
 379                     pop @line;
 380                 }
 381             } else {
 382                 while (scalar(@line) > 1) {
 383                     pop @line;
 384                 }
 385             }
 386             push(@label_lines, @line);
 387         }
 388         LABEL_LINES:    # generate lines of label text for current field
 389         foreach my $line (@label_lines) {
 390             next LABEL_LINES if $line eq '';
 391             my $string_width = C4::Labels::PDF->StrWidth($line, $font, $self->{'font_size'});
 392             if ($self->{'justify'} eq 'R') {
 393                 $text_llx = $params{'llx'} + $self->{'width'} - ($self->{'left_text_margin'} + $string_width);
 394             }
 395             elsif($self->{'justify'} eq 'C') {
 396                  # some code to try and center each line on the label based on font size and string point width...
 397                  my $whitespace = ($self->{'width'} - ($string_width + (2 * $self->{'left_text_margin'})));
 398                  $text_llx = (($whitespace  / 2) + $params{'llx'} + $self->{'left_text_margin'});
 399             }
 400             else {
 401                 $text_llx = ($params{'llx'} + $self->{'left_text_margin'});
 402             }
 403             push @label_text,   {
 404                                 text_llx        => $text_llx,
 405                                 text_lly        => $text_lly,
 406                                 font            => $font,
 407                                 font_size       => $self->{'font_size'},
 408                                 line            => $line,
 409                                 };
 410             $text_lly = $text_lly - $params{'line_spacer'};
 411         }
 412         $font = $self->{'font'};        # reset font for next field
 413     }   #foreach field
 414     return \@label_text;
 415 }
 416
 417 =head2 $label->barcode()
 418
 419     Invoking the I<barcode> method generates a barcode for the label object and inserts it into the current pdf stream. C<barcode_data> is optional
 420         and omitting it will cause the barcode from the current item to be used. C<barcode_type> is also optional. Omission results in the barcode
 421         type of the current template being used.
 422
 423     example:
 424        $label->barcode(
 425                     llx                 => $barcode_llx,
 426                     lly                 => $barcode_lly,
 427                     width               => $barcode_width,
 428                     y_scale_factor      => $barcode_y_scale_factor,
 429                     barcode_data        => $barcode,
 430                     barcode_type        => $barcodetype,
 431         );
 432 =cut
 433
 434 sub barcode {
 435     my $self = shift;
 436     my %params = @_;
 437     $params{'barcode'} = _get_label_item($self->{'item_number'}, 1) if !$params{'barcode'};
 438     $params{'barcode_type'} = $self->{'barcode_type'} if !$params{'barcode_type'};
 439     my $x_scale_factor = 1;
 440     my $num_of_bars = length($params{'barcode'});
 441     my $tot_bar_length = 0;
 442     my $bar_length = 0;
 443     my $guard_length = 10;
 444     my $hide_text = 'yes';
 445     if ($params{'barcode_type'} =~ m/CODE39/) {
 446         $bar_length = '17.5';
 447         $tot_bar_length = ($bar_length * $num_of_bars) + ($guard_length * 2);
 448         $x_scale_factor = ($params{'width'} / $tot_bar_length);
 449         if ($params{'barcode_type'} eq 'CODE39MOD') {
 450             my $c39 = CheckDigits('visa');   # get modulo43 checksum
 451             $params{'barcode'} = $c39->complete($params{'barcode'});
 452         }
 453         elsif ($params{'barcode_type'} eq 'CODE39MOD10') {
 454             my $c39_10 = CheckDigits('visa');   # get modulo43 checksum
 455             $params{'barcode'} = $c39_10->complete($params{'barcode'});
 456             $hide_text = '';
 457         }
 458         eval {
 459             PDF::Reuse::Barcode::Code39(
 460                 x                   => $params{'llx'},
 461                 y                   => $params{'lly'},
 462                 value               => "*$params{barcode}*",
 463                 xSize               => $x_scale_factor,
 464                 ySize               => $params{'y_scale_factor'},
 465                 hide_asterisk       => 1,
 466                 text                => $hide_text,
 467                 mode                => 'graphic',
 468             );
 469         };
 470         if ($@) {
 471             syslog("LOG_ERR", "Barcode generation failed for item %s with this error: %s", $self->{'item_number'}, $@);
 472         }
 473     }
 474     elsif ($params{'barcode_type'} eq 'COOP2OF5') {
 475         $bar_length = '9.43333333333333';
 476         $tot_bar_length = ($bar_length * $num_of_bars) + ($guard_length * 2);
 477         $x_scale_factor = ($params{'width'} / $tot_bar_length) * 0.9;
 478         eval {
 479             PDF::Reuse::Barcode::COOP2of5(
 480                 x                   => $params{'llx'},
 481                 y                   => $params{'lly'},
 482                 value               => "*$params{barcode}*",
 483                 xSize               => $x_scale_factor,
 484                 ySize               => $params{'y_scale_factor'},
 485                 mode                    => 'graphic',
 486             );
 487         };
 488         if ($@) {
 489             syslog("LOG_ERR", "Barcode generation failed for item %s with this error: %s", $self->{'item_number'}, $@);
 490         }
 491     }
 492     elsif ( $params{'barcode_type'} eq 'INDUSTRIAL2OF5' ) {
 493         $bar_length = '13.1333333333333';
 494         $tot_bar_length = ($bar_length * $num_of_bars) + ($guard_length * 2);
 495         $x_scale_factor = ($params{'width'} / $tot_bar_length) * 0.9;
 496         eval {
 497             PDF::Reuse::Barcode::Industrial2of5(
 498                 x                   => $params{'llx'},
 499                 y                   => $params{'lly'},
 500                 value               => "*$params{barcode}*",
 501                 xSize               => $x_scale_factor,
 502                 ySize               => $params{'y_scale_factor'},
 503                 mode                    => 'graphic',
 504             );
 505         };
 506         if ($@) {
 507             syslog("LOG_ERR", "Barcode generation failed for item %s with this error: %s", $self->{'item_number'}, $@);
 508         }
 509     }
 510 }
 511
 512 sub csv_data {
 513     my $self = shift;
 514     my $label_fields = _get_text_fields($self->{'format_string'});
 515     my $item = _get_label_item($self->{'item_number'});
 516     my $bib_record = GetMarcBiblio($item->{biblionumber});
 517     my @csv_data = (map { _get_barcode_data($_->{'code'},$item,$bib_record) } @$label_fields);
 518     return \@csv_data;
 519 }
 520
 521 1;
 522 __END__
 523
 524 =head1 AUTHOR
 525
 526 Mason James <mason@katipo.co.nz>
 527 Chris Nighswonger <cnighswonger AT foundations DOT edu>
 528
 529 =cut
 530