File Coverage

blib/lib/Business/Barcode/EAN13.pm
Criterion Covered Total %
statement 66 68 97.0
branch 29 32 90.6
condition 4 4 100.0
subroutine 10 10 100.0
pod 4 4 100.0
total 113 118 95.7


line stmt bran cond sub pod time code
1             package Business::Barcode::EAN13;
2              
3             =head1 NAME
4              
5             Business::Barcode::EAN13 - Perform simple validation of an EAN-13 barcode
6              
7             =head1 SYNOPSIS
8              
9             use Business::Barcode::EAN13 qw/valid_barcode check_digit issuer_ccode best_barcode/;
10              
11             my $is_valid = valid_barcode("5023965006028");
12             my $check_digit = check_digit("502396500602");
13             my $country_code = issuer_ccode("5023965006028");
14             my $best_code = best_barcode(\@barcodes, \@prefs);
15              
16             =head1 DESCRIPTION
17              
18             These subroutines will tell you whether or not an EAN-13 barcode is
19             self-consistent: i.e. whether or not it checksums correctly.
20             If provided with the 12 digit stem of a barcode it will also return the
21             correct check digit.
22              
23             We can also return the country in which the manufacturer's identifcation
24             code was registered, and a method for picking a "most preferred" barcode
25             from a list, given a preferred country list.
26              
27             =cut
28              
29 1     1   76322 use strict;
  1         3  
  1         36  
30 1     1   5 use base 'Exporter';
  1         2  
  1         167  
31              
32 1     1   7 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  1         2  
  1         993  
33             @EXPORT = qw//;
34             @EXPORT_OK = qw/valid_barcode check_digit issuer_ccode best_barcode/;
35             %EXPORT_TAGS = (all => [@EXPORT_OK]);
36             $VERSION = "2.10";
37              
38             # Private global HoL of country -> prefix lookup
39             my %prefix;
40              
41             sub _build_prefix {
42 1     1   7 while () {
43 117         244 chomp;
44 117         283 my ($ccode, $prefix) = split(/:/, $_, 2);
45              
46             # Allow the list to have .. and , modifiers to save typing!
47 117 100       168 push @{ $prefix{$ccode} }, ($prefix =~ /\.\.|,/) ? eval $prefix : $prefix;
  117         1247  
48             }
49             }
50              
51             =head1 FUNCTIONS
52              
53             =head2 check_digit
54              
55             my $check_digit = check_digit("502396500602"); # 8
56              
57             Given the first 12 digits of a barcode, this will tell you what the last
58             digit should be. This will return undef if the barcode stem is not
59             properly formed.
60              
61             =cut
62              
63             sub check_digit {
64 3     3 1 9 my $stem = shift;
65 3 100       7 unless (_valid_stem($stem)) {
66 1         10 require Carp;
67 1         219 Carp::carp("Barcode stems should be 12 digits");
68 1         9 return undef;
69             }
70 2 50       7 return undef unless _valid_stem($stem);
71 2         6 return _check_digit($stem);
72             }
73              
74             #-------------------------------------------------------------------------
75             # The specification for an EAN-13 barcode is described at
76             # http://www.mecsw.com/specs/ean_13.html
77             # The check_digit is basically the number which, when added to 3 times the
78             # sum of the odd-position numbers plus the sum of the even-position
79             # numbers gives you 10! A better explanation is available at that URL.
80             #-------------------------------------------------------------------------
81              
82             sub _check_digit {
83 21     21   33 my $stem = shift;
84 21         31 my $sum = 0;
85 21         41 while ($stem) {
86 126         212 $sum += (chop $stem) * 3;
87 126         217 $sum += chop $stem;
88             }
89 21         38 my $mod = 10 - ($sum % 10);
90 21 100       93 return ($mod == 10) ? 0 : $mod;
91             }
92              
93             =head2 valid_barcode
94              
95             my $is_valid = valid_barcode("5023965006028");
96              
97             Tell whether or not the given barcode is valid. This obviously does not
98             check if it a real barcode; only if it is of correct length, and has a
99             valid check-digit.
100              
101             =cut
102              
103             #--------------------------------------------------------------------------
104             # A barcode is deemed to be valid if the stem is 12 digits, and the 13th
105             # digit is the expected check digit
106             #--------------------------------------------------------------------------
107             sub valid_barcode {
108 27     27 1 133 my $bcode = shift;
109 27         54 my $check_digit = chop($bcode);
110 27 100       44 return 0 unless _valid_stem($bcode);
111 19         44 return ($check_digit == _check_digit($bcode));
112             }
113              
114             sub _valid_stem {
115 32     32   49 my $stem = shift;
116 32         138 return ($stem =~ /^\d{12}$/);
117             }
118              
119             =head2 issuer_ccode
120              
121             my $country_code = issuer_ccode("5023965006028"); # "uk"
122              
123             Returns the ISO 2 digit country code (you could use Locale::Country,
124             or equivalent, to convert to the country name, if required) of the
125             barcode issuer. (Note: This is not necessarily the same as the country
126             of manufacture of the goods).
127              
128             This does not test the validity of the barcode.
129              
130             =cut
131              
132             sub issuer_ccode {
133 4     4 1 523 my $bcode = shift;
134              
135             # We should really build a hash lookup in the opposite direction here
136 4 50       13 _build_prefix() unless %prefix;
137              
138 4         64 foreach (keys %prefix) {
139 301 100       485 return $_ if (my @match = grep { $bcode =~ /^$_/ } @{ $prefix{$_} });
  522         3693  
  301         488  
140             }
141 1         11 return "";
142             }
143              
144             =head2 best_barcode
145              
146             my $best_barcode = best_barcode(\@list_of_barcodes, \@optional_prefs);
147              
148             Given an arrayref of barcodes, this will return the "most preferred"
149             barcode from the list.
150              
151             If you don't pass any preferences, this will be the first valid barcode
152             in the list. With a list of "preferred prefixes", this will return the
153             best match from your list in order of preference of your prefix. A
154             prefix can either be a numeric barcode stem, or a 2 letter country code,
155             which will be expanded into the list of current barcode stems available
156             to that country.
157              
158             e.g. if you have a list of 10 barcodes for the same product
159             internationally, and would prefer the UK barcode if it exists, otherwise
160             the Irish one, otherwise any valid barcode, you would call:
161              
162             my $best_barcode = best_barcode(\@barcodes, ["uk", "ie"]);
163              
164             If there are no valid barcodes in your list this will return the first
165             barcode which would be valid if it was zero-padded, or null if none
166             meet this final criterion.
167              
168             =cut
169              
170             sub best_barcode {
171 10     10 1 4907 my $bref = shift;
172 10   100     38 my $pref_ref = shift || [];
173 10 100       28 _build_prefix() unless %prefix;
174 10 100       27 my @prefs = map { @{ $prefix{$_} || [$_] } } @$pref_ref;
  13         18  
  13         66  
175              
176 10         20 my $best = "";
177 10         15 my @invalids;
178 10         21 BARCODE: foreach my $barcode (@$bref) {
179 22 100       37 unless (valid_barcode($barcode)) {
180 13 100       33 push @invalids => $barcode if (length $barcode < 13);
181 13         28 next BARCODE;
182             }
183              
184             # if we have no conditions, then any valid match wins ...
185 9 100       26 return $barcode unless @prefs;
186 8         26 PREF: foreach my $pref (0 .. @prefs - 1) {
187 10 100       144 next PREF unless ($barcode =~ /^$prefs[$pref]/);
188 7 100       40 return $barcode if ($pref == 0);
189 2         5 $best = $barcode;
190 2         4 splice @prefs, $pref;
191 2         6 next BARCODE;
192             }
193 1         5 $best = $barcode;
194             }
195              
196             # We have no valid matches, so check the invalids.
197             # We should really check the preferences again here,
198             # perhaps with something like:
199             # return $best if $best;
200             # return undef unless @invalids;
201             # my @padded = map { sprintf "%013s", $_ }, @invalids;
202             # return best_barcode(\@padded);
203              
204 4 100       34 unless ($best) {
205 3         7 foreach my $barcode (@invalids) {
206 3         14 $barcode = sprintf "%013s", $barcode;
207 3 50       7 next unless valid_barcode($barcode);
208 0         0 $best = $barcode;
209 0         0 last;
210             }
211             }
212 4   100     26 return $best || undef;
213             }
214              
215             =head1 BUGS
216              
217             When zero-filling the barcodes in "best_barcode" we should re-apply the
218             preferences again, rather than just taking the first valid barcode.
219              
220             =head1 TODO
221              
222             Allow other barcode families than EAN-13
223              
224             =head1 AUTHOR
225              
226             Colm Dougan, Tony Bowden and Jan Willamowius (https://www.ean-search.org)
227              
228             =head1 LICENSE
229              
230             This program may be distributed under the same license as Perl itself.
231              
232             =cut
233              
234             return q/
235             i don't want the world i just want your half
236             /;
237              
238             # Here lies the mapping data from country to barcode-prefix.
239             __DATA__