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