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