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