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
 139         $debug and warn "$incr";
 140         $head = $self->process_head($head,$max,$specific);
 141         $tail = $self->process_tail($tail,$max,$specific);
 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 undef;
 148         (@_) and $self->{next} = shift;
 149         return $self->{next};
 150 }
 151 sub previous ($;$) {
 152         my $self = shift or return undef;
 153         (@_) and $self->{previous} = shift;
 154         return $self->{previous};
 155 }
 156 sub serial ($;$) {
 157         my $self = shift or return undef;
 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 };
 181
 182 sub new {
 183         my $class_or_object = shift;
 184         my $type = ref($class_or_object) || $class_or_object;
 185         my $from_obj = ref($class_or_object) ? 1 : 0;   # are we building off another Barcodes object?
 186         if ($from_obj) {
 187                 $debug and print STDERR "Building new(@_) from old Barcodes object\n";
 188         }
 189         my $autoBarcodeType = (@_) ? shift : $from_obj ? $class_or_object->autoBarcode : _prefformat;
 190         $autoBarcodeType =~ s/^.*:://;  # in case we get C4::Barcodes::incremental, we just want 'incremental'
 191         unless ($autoBarcodeType) {
 192                 carp "No autoBarcode format found.";
 193                 return undef;
 194         }
 195         unless (defined $types->{$autoBarcodeType}) {
 196                 carp "The autoBarcode format '$autoBarcodeType' is unrecognized.";
 197                 return undef;
 198         }
 199         carp "autoBarcode format = $autoBarcodeType" if $debug;
 200         my $self;
 201         if ($autoBarcodeType eq 'OFF') {
 202                 $self = $class_or_object->default_self($autoBarcodeType);
 203                 return bless $self, $class_or_object;
 204         } elsif ($from_obj) {
 205                 $class_or_object->autoBarcode eq $autoBarcodeType
 206                         or carp "Cannot create Barcodes object (type '$autoBarcodeType') from " . $class_or_object->autoBarcode . " object!";
 207                 $self = $class_or_object->new_object(@_);
 208                 $self->serial($class_or_object->serial + 1);
 209                 if ($class_or_object->is_max) {
 210                         $debug and print STDERR "old object was max: ", $class_or_object->value, "\n";
 211                         $self->previous($class_or_object);
 212                         $class_or_object->next($self);
 213                         $self->value($self->next_value($class_or_object->value));
 214                         $self->is_max(1) and $class_or_object->is_max(0);  # new object is max, old object is no longer max
 215                 } else {
 216                         $self->value($self->next_value);
 217                 }
 218         } else {
 219                 $debug and print STDERR "trying to create new $autoBarcodeType\n";
 220                 $self = &{$types->{$autoBarcodeType}} (@_);
 221                 $self->value($self->next_value) and $self->is_max(1);
 222                 $self->serial(1);
 223         }
 224         if ($self) {
 225                 return $self;
 226         }
 227         carp "Failed new C4::Barcodes::$autoBarcodeType";
 228         return undef;
 229 }
 230
 231 sub new_object {
 232         my $class_or_object = shift;
 233         my $type = ref($class_or_object) || $class_or_object;
 234         my $from_obj = ref($class_or_object) ? 1 : 0;   # are we building off another Barcodes object?
 235         my $self = $class_or_object->default_self($from_obj ? $class_or_object->autoBarcode : 'incremental');
 236         bless $self, $type;
 237         return $self;
 238 }
 239 1;
 240 __END__
 241
 242 =head1 Barcodes
 243
 244 Note that the object returned by new is actually of the type requested (or set by syspref).
 245 For example, C4::Barcodes::annual
 246
 247 The specific C4::Barcodes::* modules correspond to the autoBarcode syspref values.
 248
 249 The default behavior here in Barcodes should be essentially a more flexible version of "incremental".
 250
 251 =head1 Adding New Barcode Types
 252
 253 To add a new barcode format, a developer should:
 254
 255         create a module in C4/Barcodes/, like C4/Barcodes/my_new_format.pm;
 256         add to the $types hashref in this file;
 257         add tests under the "t" directory; and
 258         edit autoBarcode syspref to include new type.
 259
 260 =head2 Adding a new module
 261
 262 Each new module that needs differing behavior must override these subs:
 263
 264         new_object
 265         initial
 266         db_max
 267         parse
 268
 269 Or else the CLASS subs will be used.
 270
 271 =head2 $types hashref
 272
 273 The hash referenced can be thought of as the constructor farm for all the C4::Barcodes types.
 274 Each value should be a reference to a sub that calls the module constructor.
 275
 276 =head1 Notes
 277
 278 You would think it might be easy to handle incremental barcodes, but in practice even commonly used values,
 279 like the IBM "Boulder" format can cause problems for sprintf.  Basically, the value is too large for the
 280 %d version of an integer, and we cannot count on perl having been compiled with support for quads
 281 (64-bit integers).  So we have to use floats or increment a piece of it and return the rejoined fragments.
 282
 283 =cut
 284