"Fossies" - the Fresh Open Source Software Archive

Member "koha-19.11.15/C4/Barcodes.pm" (23 Feb 2021, 9147 Bytes) of package /linux/misc/koha-19.11.15.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Barcodes.pm" see the Fossies "Dox" file reference documentation.

    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