C4/Barcodes.pm

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