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 under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along
  17 # with Koha; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  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
  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 = 0.01;
  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 undef;
  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 undef;
 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 undesireable for some barcode formats.
 136                 # Those should override next_value() to work accordingly.
 137         $incr++;
 138         my $width = $self->width || undef;
 139         # we would want to use %$x.$xd, but that would break on large values, like 2160700004168
 140         # so we let the object tell us if it has a width to focus on.  If not, we use float.
 141         my $format = ($width ? '%'."$width.$width".'d' : '%.0f');
 142         $debug and warn "sprintf(\"$format\",$incr)";
 143         $head = $self->process_head($head,$max,$specific);
 144         $tail = $self->process_tail($tail,$max,$specific);
 145         my $next_value = $head . sprintf($format,$incr) . $tail;
 146         $debug and print STDERR "(  next ) max barcode found: $next_value\n";
 147         return $next_value;
 148 }
 149 sub next ($;$) {
 150         my $self = shift or return undef;
 151         (@_) and $self->{next} = shift;
 152         return $self->{next};
 153 }
 154 sub previous ($;$) {
 155         my $self = shift or return undef;
 156         (@_) and $self->{previous} = shift;
 157         return $self->{previous};
 158 }
 159 sub serial ($;$) {
 160         my $self = shift or return undef;
 161         (@_) and $self->{serial} = shift;
 162         return $self->{serial};
 163 }
 164 sub default_self (;$) {
 165         (@_) or carp "default_self called with no argument.  Reverting to _prefformat.";
 166         my $autoBarcode = (@_) ? shift : _prefformat;
 167         $autoBarcode =~ s/^.*:://;  # in case we get C4::Barcodes::incremental, we just want 'incremental'
 168         return {
 169                 is_max => 0,
 170                 autoBarcode => $autoBarcode,
 171                    value => undef,
 172                 previous => undef,
 173                   'next' => undef,
 174                 serial => 1
 175         };
 176 }
 177
 178 our $types = {
 179         annual      => sub {C4::Barcodes::annual->new_object(@_);     },
 180         incremental => sub {C4::Barcodes::incremental->new_object(@_);},
 181         hbyymmincr  => sub {C4::Barcodes::hbyymmincr->new_object(@_); },
 182         OFF         => sub {C4::Barcodes::OFF->new_object(@_);        },
 183 };
 184
 185 sub new {
 186         my $class_or_object = shift;
 187         my $type = ref($class_or_object) || $class_or_object;
 188         my $from_obj = ref($class_or_object) ? 1 : 0;   # are we building off another Barcodes object?
 189         if ($from_obj) {
 190                 $debug and print STDERR "Building new(@_) from old Barcodes object\n";
 191         }
 192         my $autoBarcodeType = (@_) ? shift : $from_obj ? $class_or_object->autoBarcode : _prefformat;
 193         $autoBarcodeType =~ s/^.*:://;  # in case we get C4::Barcodes::incremental, we just want 'incremental'
 194         unless ($autoBarcodeType) {
 195                 carp "No autoBarcode format found.";
 196                 return undef;
 197         }
 198         unless (defined $types->{$autoBarcodeType}) {
 199                 carp "The autoBarcode format '$autoBarcodeType' is unrecognized.";
 200                 return undef;
 201         }
 202         carp "autoBarcode format = $autoBarcodeType" if $debug;
 203         my $self;
 204         if ($autoBarcodeType eq 'OFF') {
 205                 $self = $class_or_object->default_self($autoBarcodeType);
 206                 return bless $self, $class_or_object;
 207         } elsif ($from_obj) {
 208                 $class_or_object->autoBarcode eq $autoBarcodeType
 209                         or carp "Cannot create Barcodes object (type '$autoBarcodeType') from " . $class_or_object->autoBarcode . " object!";
 210                 $self = $class_or_object->new_object(@_);
 211                 $self->serial($class_or_object->serial + 1);
 212                 if ($class_or_object->is_max) {
 213                         $debug and print STDERR "old object was max: ", $class_or_object->value, "\n";
 214                         $self->previous($class_or_object);
 215                         $class_or_object->next($self);
 216                         $self->value($self->next_value($class_or_object->value));
 217                         $self->is_max(1) and $class_or_object->is_max(0);  # new object is max, old object is no longer max
 218                 } else {
 219                         $self->value($self->next_value);
 220                 }
 221         } else {
 222                 $debug and print STDERR "trying to create new $autoBarcodeType\n";
 223                 $self = &{$types->{$autoBarcodeType}} (@_);
 224                 $self->value($self->next_value) and $self->is_max(1);
 225                 $self->serial(1);
 226         }
 227         if ($self) {
 228                 return $self;
 229         }
 230         carp "Failed new C4::Barcodes::$autoBarcodeType";
 231         return undef;
 232 }
 233
 234 sub new_object {
 235         my $class_or_object = shift;
 236         my $type = ref($class_or_object) || $class_or_object;
 237         my $from_obj = ref($class_or_object) ? 1 : 0;   # are we building off another Barcodes object?
 238         my $self = $class_or_object->default_self($from_obj ? $class_or_object->autoBarcode : 'incremental');
 239         bless $self, $type;
 240         return $self;
 241 }
 242 1;
 243 __END__
 244
 245 =head1 Barcodes
 246
 247 Note that the object returned by new is actually of the type requested (or set by syspref).
 248 For example, C4::Barcodes::annual
 249
 250 The specific C4::Barcodes::* modules correspond to the autoBarcode syspref values.
 251
 252 The default behavior here in Barcodes should be essentially a more flexible version of "incremental".
 253
 254 =head1 Adding New Barcode Types
 255
 256 To add a new barcode format, a developer should:
 257
 258         create a module in C4/Barcodes/, like C4/Barcodes/my_new_format.pm;
 259         add to the $types hashref in this file;
 260         add tests under the "t" directory; and
 261         edit autoBarcode syspref to include new type.
 262
 263 =head2 Adding a new module
 264
 265 Each new module that needs differing behavior must override these subs:
 266
 267         new_object
 268         initial
 269         db_max
 270         parse
 271
 272 Or else the CLASS subs will be used.
 273
 274 =head2 $types hashref
 275
 276 The hash referenced can be thought of as the constructor farm for all the C4::Barcodes types.
 277 Each value should be a reference to a sub that calls the module constructor.
 278
 279 =head1 Notes
 280
 281 You would think it might be easy to handle incremental barcodes, but in practice even commonly used values,
 282 like the IBM "Boulder" format can cause problems for sprintf.  Basically, the value is too large for the
 283 %d version of an integer, and we cannot count on perl having been compiled with support for quads
 284 (64-bit integers).  So we have to use floats or increment a piece of it and return the rejoined fragments.
 285
 286 =cut
 287