C4/Barcodes.pm

   1 package C4::Barcodes;
   2
   3 # Copyright 2008 LibLime
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use strict;
  21 use warnings;
  22
  23 use Carp qw( carp );
  24
  25 use C4::Context;
  26 use C4::Barcodes::hbyymmincr;
  27 use C4::Barcodes::annual;
  28 use C4::Barcodes::incremental;
  29 use C4::Barcodes::EAN13;
  30
  31 use vars qw($max $prefformat);
  32
  33 sub _prefformat {
  34         unless (defined $prefformat) {
  35                 unless ($prefformat = C4::Context->preference('autoBarcode')) {
  36                         carp "The autoBarcode syspref is missing/undefined.  Assuming 'incremental'.";
  37                         $prefformat = 'incremental';
  38                 }
  39         }
  40         return $prefformat;
  41 }
  42
  43 sub initial {
  44         return '0000001';
  45 }
  46 sub width {
  47         return;
  48 }
  49 sub process_head {      # (self,head,whole,specific)
  50         my $self = shift;
  51         return shift;                   # Default: just return the head unchanged.
  52 }
  53 sub process_tail {      # (self,tail,whole,specific)
  54         my $self = shift;
  55         return shift;                   # Default: just return the tail unchanged.
  56 }
  57 sub is_max {
  58         my $self = shift;
  59         ref($self) or carp "Called is_max on a non-object: '$self'";
  60         (@_) and $self->{is_max} = shift;
  61         return $self->{is_max} || 0;
  62 }
  63 sub value {
  64         my $self = shift;
  65         if (@_) {
  66                 my $value = shift;
  67         warn "Error: UNDEF argument to value"
  68             unless defined $value;
  69                 $self->{value} = $value;
  70         }
  71         return $self->{value};
  72 }
  73 sub autoBarcode {
  74         (@_) or return _prefformat;
  75         my $self = shift;
  76         my $value = $self->{autoBarcode} or return _prefformat;
  77         $value =~ s/^.*:://;    # in case we get C4::Barcodes::incremental, we just want 'incremental'
  78         return $value;
  79 }
  80 sub parse {     # return 3 parts of barcode: non-incrementing, incrementing, non-incrementing
  81         my $self = shift;
  82         my $barcode = (@_) ? shift : $self->value;
  83         unless ($barcode =~ /(.*?)(\d+)$/) {    # non-greedy match in first part
  84                 carp "Barcode '$barcode' has no incrementing part!";
  85                 return ($barcode,undef,undef);
  86         }
  87         return ($1,$2,'');      # the third part is in anticipation of barcodes that include checkdigits
  88 }
  89 sub max {
  90         my $self = shift;
  91         if ($self->{is_max}) {
  92                 return $self->value;
  93         }
  94         return $self->db_max;
  95 }
  96 sub db_max {
  97         my $self = shift;
  98         my $query = "SELECT max(abs(barcode)) FROM items LIMIT 1"; # Possible problem if multiple barcode types populated
  99         my $sth = C4::Context->dbh->prepare($query);
 100         $sth->execute();
 101         return $sth->fetchrow_array || $self->initial;
 102 }
 103 sub next_value {
 104         my $self = shift;
 105         my $specific = (scalar @_) ? 1 : 0;
 106         my $max = $specific ? shift : $self->max;               # optional argument, i.e. next_value after X
 107         unless ($max) {
 108                 warn "No max barcode ($self->autoBarcode format) found.  Using initial value.";
 109                 return $self->initial;
 110         }
 111         my ($head,$incr,$tail) = $self->parse($max);    # for incremental, you'd get ('',the_whole_barcode,'')
 112         unless (defined $incr) {
 113                 warn "No incrementing part of barcode ($max) returned by parse.";
 114                 return;
 115         }
 116         my $x = length($incr);          # number of digits
 117         $incr =~ /^9+$/ and $x++;       # if they're all 9's, we need an extra.
 118         # Note, this enlargement might be undesirable for some barcode formats.
 119                 # Those should override next_value() to work accordingly.
 120         $incr++;
 121
 122         $head = $self->process_head($head,$max,$specific);
 123     $tail = $self->process_tail($tail,$incr,$specific); # XXX use $incr and not $max!
 124         my $next_value = $head . $incr . $tail;
 125         return $next_value;
 126 }
 127 sub next {
 128         my $self = shift or return;
 129         (@_) and $self->{next} = shift;
 130         return $self->{next};
 131 }
 132 sub previous {
 133         my $self = shift or return;
 134         (@_) and $self->{previous} = shift;
 135         return $self->{previous};
 136 }
 137 sub serial {
 138         my $self = shift or return;
 139         (@_) and $self->{serial} = shift;
 140         return $self->{serial};
 141 }
 142 sub default_self {
 143         (@_) or carp "default_self called with no argument.  Reverting to _prefformat.";
 144         my $autoBarcode = (@_) ? shift : _prefformat;
 145         $autoBarcode =~ s/^.*:://;  # in case we get C4::Barcodes::incremental, we just want 'incremental'
 146         return {
 147                 is_max => 0,
 148                 autoBarcode => $autoBarcode,
 149                    value => undef,
 150                 previous => undef,
 151                   'next' => undef,
 152                 serial => 1
 153         };
 154 }
 155
 156 our $types = {
 157         annual      => sub {C4::Barcodes::annual->new_object(@_);     },
 158         incremental => sub {C4::Barcodes::incremental->new_object(@_);},
 159         hbyymmincr  => sub {C4::Barcodes::hbyymmincr->new_object(@_); },
 160         OFF         => sub {C4::Barcodes::OFF->new_object(@_);        },
 161     EAN13       => sub {C4::Barcodes::EAN13->new_object(@_);      },
 162 };
 163
 164 sub new {
 165         my $class_or_object = shift;
 166         my $type = ref($class_or_object) || $class_or_object;
 167         my $from_obj = ref($class_or_object) ? 1 : 0;   # are we building off another Barcodes object?
 168         my $autoBarcodeType = (@_) ? shift : $from_obj ? $class_or_object->autoBarcode : _prefformat;
 169         $autoBarcodeType =~ s/^.*:://;  # in case we get C4::Barcodes::incremental, we just want 'incremental'
 170         unless ($autoBarcodeType) {
 171                 carp "No autoBarcode format found.";
 172                 return;
 173         }
 174         unless (defined $types->{$autoBarcodeType}) {
 175                 carp "The autoBarcode format '$autoBarcodeType' is unrecognized.";
 176                 return;
 177         }
 178         my $self;
 179         if ($autoBarcodeType eq 'OFF') {
 180                 $self = $class_or_object->default_self($autoBarcodeType);
 181                 return bless $self, $class_or_object;
 182         } elsif ($from_obj) {
 183                 $class_or_object->autoBarcode eq $autoBarcodeType
 184                         or carp "Cannot create Barcodes object (type '$autoBarcodeType') from " . $class_or_object->autoBarcode . " object!";
 185                 $self = $class_or_object->new_object(@_);
 186                 $self->serial($class_or_object->serial + 1);
 187                 if ($class_or_object->is_max) {
 188                         $self->previous($class_or_object);
 189                         $class_or_object->next($self);
 190                         $self->value($self->next_value($class_or_object->value));
 191                         $self->is_max(1) and $class_or_object->is_max(0);  # new object is max, old object is no longer max
 192                 } else {
 193                         $self->value($self->next_value);
 194                 }
 195         } else {
 196                 $self = &{$types->{$autoBarcodeType}} (@_);
 197                 $self->value($self->next_value) and $self->is_max(1);
 198                 $self->serial(1);
 199         }
 200         if ($self) {
 201                 return $self;
 202         }
 203         carp "Failed new C4::Barcodes::$autoBarcodeType";
 204         return;
 205 }
 206
 207 sub new_object {
 208         my $class_or_object = shift;
 209         my $type = ref($class_or_object) || $class_or_object;
 210         my $from_obj = ref($class_or_object) ? 1 : 0;   # are we building off another Barcodes object?
 211         my $self = $class_or_object->default_self($from_obj ? $class_or_object->autoBarcode : 'incremental');
 212         bless $self, $type;
 213         return $self;
 214 }
 215 1;
 216 __END__
 217
 218 =head1 Barcodes
 219
 220 Note that the object returned by new is actually of the type requested (or set by syspref).
 221 For example, C4::Barcodes::annual
 222
 223 The specific C4::Barcodes::* modules correspond to the autoBarcode syspref values.
 224
 225 The default behavior here in Barcodes should be essentially a more flexible version of "incremental".
 226
 227 =head1 Adding New Barcode Types
 228
 229 To add a new barcode format, a developer should:
 230
 231         create a module in C4/Barcodes/, like C4/Barcodes/my_new_format.pm;
 232         add to the $types hashref in this file;
 233         add tests under the "t" directory; and
 234         edit autoBarcode syspref to include new type.
 235
 236 =head2 Adding a new module
 237
 238 Each new module that needs differing behavior must override these subs:
 239
 240         new_object
 241         initial
 242         db_max
 243         parse
 244
 245 Or else the CLASS subs will be used.
 246
 247 =head2 $types hashref
 248
 249 The hash referenced can be thought of as the constructor farm for all the C4::Barcodes types.
 250 Each value should be a reference to a sub that calls the module constructor.
 251
 252 =head1 Notes
 253
 254 You would think it might be easy to handle incremental barcodes, but in practice even commonly used values,
 255 like the IBM "Boulder" format can cause problems for sprintf.  Basically, the value is too large for the
 256 %d version of an integer, and we cannot count on perl having been compiled with support for quads
 257 (64-bit integers).  So we have to use floats or increment a piece of it and return the rejoined fragments.
 258
 259 =cut
 260