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(@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         require Exporter;
  38     @ISA = qw(Exporter);
  39     @EXPORT_OK = qw();
  40 }
  41
  42 sub _prefformat {
  43         unless (defined $prefformat) {
  44                 unless ($prefformat = C4::Context->preference('autoBarcode')) {
  45                         carp "The autoBarcode syspref is missing/undefined.  Assuming 'incremental'.";
  46                         $prefformat = 'incremental';
  47                 }
  48         }
  49         return $prefformat;
  50 }
  51
  52 sub initial {
  53         return '0000001';
  54 }
  55 sub width {
  56         return;
  57 }
  58 sub process_head {      # (self,head,whole,specific)
  59         my $self = shift;
  60         return shift;                   # Default: just return the head unchanged.
  61 }
  62 sub process_tail {      # (self,tail,whole,specific)
  63         my $self = shift;
  64         return shift;                   # Default: just return the tail unchanged.
  65 }
  66 sub is_max {
  67         my $self = shift;
  68         ref($self) or carp "Called is_max on a non-object: '$self'";
  69         (@_) and $self->{is_max} = shift;
  70         return $self->{is_max} || 0;
  71 }
  72 sub value {
  73         my $self = shift;
  74         if (@_) {
  75                 my $value = shift;
  76                 if (defined $value) {
  77                         $debug and print STDERR "    setting barcode value to $value\n";
  78                 } else {
  79                         warn "Error: UNDEF argument to value";
  80                 }
  81                 $self->{value} = $value;
  82         }
  83         return $self->{value};
  84 }
  85 sub autoBarcode {
  86         (@_) or return _prefformat;
  87         my $self = shift;
  88         my $value = $self->{autoBarcode} or return _prefformat;
  89         $value =~ s/^.*:://;    # in case we get C4::Barcodes::incremental, we just want 'incremental'
  90         return $value;
  91 }
  92 sub parse {     # return 3 parts of barcode: non-incrementing, incrementing, non-incrementing
  93         my $self = shift;
  94         my $barcode = (@_) ? shift : $self->value;
  95         unless ($barcode =~ /(.*?)(\d+)$/) {    # non-greedy match in first part
  96                 carp "Barcode '$barcode' has no incrementing part!";
  97                 return ($barcode,undef,undef);
  98         }
  99         $debug and warn "Barcode '$barcode' parses into: '$1', '$2', ''";
 100         return ($1,$2,'');      # the third part is in anticipation of barcodes that include checkdigits
 101 }
 102 sub max {
 103         my $self = shift;
 104         if ($self->{is_max}) {
 105                 $debug and print STDERR "max taken from Barcodes value $self->value\n";
 106                 return $self->value;
 107         }
 108         $debug and print STDERR "Retrieving max database query.\n";
 109         return $self->db_max;
 110 }
 111 sub db_max {
 112         my $self = shift;
 113         my $query = "SELECT max(abs(barcode)) FROM items LIMIT 1"; # Possible problem if multiple barcode types populated
 114         my $sth = C4::Context->dbh->prepare($query);
 115         $sth->execute();
 116         return $sth->fetchrow_array || $self->initial;
 117 }
 118 sub next_value {
 119         my $self = shift;
 120         my $specific = (scalar @_) ? 1 : 0;
 121         my $max = $specific ? shift : $self->max;               # optional argument, i.e. next_value after X
 122         unless ($max) {
 123                 warn "No max barcode ($self->autoBarcode format) found.  Using initial value.";
 124                 return $self->initial;
 125         }
 126         $debug and print STDERR "(current) max barcode found: $max\n";
 127         my ($head,$incr,$tail) = $self->parse($max);    # for incremental, you'd get ('',the_whole_barcode,'')
 128         unless (defined $incr) {
 129                 warn "No incrementing part of barcode ($max) returned by parse.";
 130                 return;
 131         }
 132         my $x = length($incr);          # number of digits
 133         $incr =~ /^9+$/ and $x++;       # if they're all 9's, we need an extra.
 134         # Note, this enlargement might be undesirable for some barcode formats.
 135                 # Those should override next_value() to work accordingly.
 136         $incr++;
 137
 138         $debug and warn "$incr";
 139         $head = $self->process_head($head,$max,$specific);
 140     $tail = $self->process_tail($tail,$incr,$specific); # XXX use $incr and not $max!
 141         my $next_value = $head . $incr . $tail;
 142         $debug and print STDERR "(  next ) max barcode found: $next_value\n";
 143         return $next_value;
 144 }
 145 sub next {
 146         my $self = shift or return;
 147         (@_) and $self->{next} = shift;
 148         return $self->{next};
 149 }
 150 sub previous {
 151         my $self = shift or return;
 152         (@_) and $self->{previous} = shift;
 153         return $self->{previous};
 154 }
 155 sub serial {
 156         my $self = shift or return;
 157         (@_) and $self->{serial} = shift;
 158         return $self->{serial};
 159 }
 160 sub default_self {
 161         (@_) or carp "default_self called with no argument.  Reverting to _prefformat.";
 162         my $autoBarcode = (@_) ? shift : _prefformat;
 163         $autoBarcode =~ s/^.*:://;  # in case we get C4::Barcodes::incremental, we just want 'incremental'
 164         return {
 165                 is_max => 0,
 166                 autoBarcode => $autoBarcode,
 167                    value => undef,
 168                 previous => undef,
 169                   'next' => undef,
 170                 serial => 1
 171         };
 172 }
 173
 174 our $types = {
 175         annual      => sub {C4::Barcodes::annual->new_object(@_);     },
 176         incremental => sub {C4::Barcodes::incremental->new_object(@_);},
 177         hbyymmincr  => sub {C4::Barcodes::hbyymmincr->new_object(@_); },
 178         OFF         => sub {C4::Barcodes::OFF->new_object(@_);        },
 179     EAN13       => sub {C4::Barcodes::EAN13->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;
 194         }
 195         unless (defined $types->{$autoBarcodeType}) {
 196                 carp "The autoBarcode format '$autoBarcodeType' is unrecognized.";
 197                 return;
 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;
 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