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