5 # Copyright 2008 LibLime
7 # This file is part of Koha.
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
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.
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
30 use C4::Barcodes::hbyymmincr;
31 use C4::Barcodes::annual;
32 use C4::Barcodes::incremental;
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);
46 unless (defined $prefformat) {
47 unless ($prefformat = C4::Context->preference('autoBarcode')) {
48 carp "The autoBarcode syspref is missing/undefined. Assuming 'incremental'.";
49 $prefformat = 'incremental';
61 sub process_head($$;$$) { # (self,head,whole,specific)
63 return shift; # Default: just return the head unchanged.
65 sub process_tail($$;$$) { # (self,tail,whole,specific)
67 return shift; # Default: just return the tail unchanged.
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;
80 $debug and print STDERR " setting barcode value to $value\n";
82 warn "Error: UNDEF argument to value";
84 $self->{value} = $value;
86 return $self->{value};
88 sub autoBarcode (;$) {
89 (@_) or return _prefformat;
91 my $value = $self->{autoBarcode} or return _prefformat;
92 $value =~ s/^.*:://; # in case we get C4::Barcodes::incremental, we just want 'incremental'
95 sub parse ($;$) { # return 3 parts of barcode: non-incrementing, incrementing, non-incrementing
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);
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
107 if ($self->{is_max}) {
108 $debug and print STDERR "max taken from Barcodes value $self->value\n";
111 $debug and print STDERR "Retrieving max database query.\n";
112 return $self->db_max;
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);
119 return $sth->fetchrow_array || $self->initial;
121 sub next_value ($;$) {
123 my $specific = (scalar @_) ? 1 : 0;
124 my $max = $specific ? shift : $self->max; # optional argument, i.e. next_value after X
126 warn "No max barcode ($self->autoBarcode format) found. Using initial value.";
127 return $self->initial;
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.";
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.
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";
152 my $self = shift or return undef;
153 (@_) and $self->{next} = shift;
154 return $self->{next};
157 my $self = shift or return undef;
158 (@_) and $self->{previous} = shift;
159 return $self->{previous};
162 my $self = shift or return undef;
163 (@_) and $self->{serial} = shift;
164 return $self->{serial};
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'
172 autoBarcode => $autoBarcode,
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(@_); },
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?
192 $debug and print STDERR "Building new(@_) from old Barcodes object\n";
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.";
200 unless (defined $types->{$autoBarcodeType}) {
201 carp "The autoBarcode format '$autoBarcodeType' is unrecognized.";
204 carp "autoBarcode format = $autoBarcodeType" if $debug;
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
221 $self->value($self->next_value);
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);
232 carp "Failed new C4::Barcodes::$autoBarcodeType";
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');
251 Note that the object returned by new is actually of the type requested (or set by syspref).
252 For example, C4::Barcodes::annual
254 The specific C4::Barcodes::* modules correspond to the autoBarcode syspref values.
256 The default behavior here in Barcodes should be essentially a more flexible version of "incremental".
258 =head1 Adding New Barcode Types
260 To add a new barcode format, a developer should:
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.
267 =head2 Adding a new module
269 Each new module that needs differing behavior must override these subs:
276 Or else the CLASS subs will be used.
278 =head2 $types hashref
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.
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.