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

package Business::Barcode::EAN13;

=head1 NAME

Business::Barcode::EAN13 - Perform simple validation of an EAN-13 barcode

=head1 SYNOPSIS

  use Business::Barcode::EAN13 qw/valid_barcode check_digit issuer_ccode best_barcode/;

  my $is_valid     = valid_barcode("5023965006028");
  my $check_digit  = check_digit("502396500602");
  my $country_code = issuer_ccode("5023965006028");
  my $best_code    = best_barcode(\@barcodes, \@prefs);

=head1 DESCRIPTION

These subroutines will tell you whether or not an EAN-13 barcode is
self-consistent: i.e. whether or not it checksums correctly.
If provided with the 12 digit stem of a barcode it will also return the
correct check digit.

We can also return the country in which the manufacturer's identifcation
code was registered, and a method for picking a "most preferred" barcode
from a list, given a preferred country list.

=cut

use strict;
use base 'Exporter';

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@EXPORT      = qw//;
@EXPORT_OK   = qw/valid_barcode check_digit issuer_ccode best_barcode/;
%EXPORT_TAGS = (all => [@EXPORT_OK]);
$VERSION     = "2.11";

# Private global HoL of country -> prefix lookup
my %prefix;

sub _build_prefix {
	while () {
		chomp;
		my ($ccode, $prefix) = split(/:/, $_, 2);

		# Allow the list to have .. and , modifiers to save typing!
		push @{ $prefix{$ccode} }, ($prefix =~ /\.\.|,/) ? eval $prefix : $prefix;
	}
}

=head1 FUNCTIONS

=head2 check_digit

my $check_digit = check_digit("502396500602");    # 8

Given the first 12 digits of a barcode, this will tell you what the last
digit should be. This will return undef if the barcode stem is not
properly formed.

=cut

sub check_digit {
	my $stem = shift;
	unless (_valid_stem($stem)) {
		require Carp;
		Carp::carp("Barcode stems should be 12 digits");
		return undef;
	}
	return undef unless _valid_stem($stem);
	return _check_digit($stem);
}

#-------------------------------------------------------------------------
# The specification for an EAN-13 barcode is described at
#  http://www.mecsw.com/specs/ean_13.html
# The check_digit is basically the number which, when added to 3 times the
# sum of the odd-position numbers plus the sum of the even-position
# numbers gives you 10! A better explanation is available at that URL.
#-------------------------------------------------------------------------

sub _check_digit {
	my $stem = shift;
	my $sum  = 0;
	while ($stem) {
		$sum += (chop $stem) * 3;
		$sum += chop $stem;
	}
	my $mod = 10 - ($sum % 10);
	return ($mod == 10) ? 0 : $mod;
}

=head2 valid_barcode

my $is_valid = valid_barcode("5023965006028");

Tell whether or not the given barcode is valid. This obviously does not
check if it a real barcode; only if it is of correct length, and has a
valid check-digit.

=cut

#--------------------------------------------------------------------------
# A barcode is deemed to be valid if the stem is 12 digits, and the 13th
# digit is the expected check digit
#--------------------------------------------------------------------------
sub valid_barcode {
	my $bcode       = shift;
	my $check_digit = chop($bcode);
	return 0 unless _valid_stem($bcode);
	return ($check_digit == _check_digit($bcode));
}

sub _valid_stem {
	my $stem = shift;
	return ($stem =~ /^\d{12}$/);
}

=head2 issuer_ccode

my $country_code = issuer_ccode("5023965006028"); # "uk"

Returns the ISO 2 digit country code (you could use Locale::Country,
or equivalent, to convert to the country name, if required) of the
barcode issuer. (Note: This is not necessarily the same as the country
of manufacture of the goods).

This does not test the validity of the barcode.

=cut

sub issuer_ccode {
	my $bcode = shift;

	# We should really build a hash lookup in the opposite direction here
	_build_prefix() unless %prefix;

	foreach (keys %prefix) {
		return $_ if (my @match = grep { $bcode =~ /^$_/ } @{ $prefix{$_} });
	}
	return "";
}

=head2 best_barcode

my $best_barcode = best_barcode(\@list_of_barcodes, \@optional_prefs);

Given an arrayref of barcodes, this will return the "most preferred"
barcode from the list.

If you don't pass any preferences, this will be the first valid barcode
in the list. With a list of "preferred prefixes", this will return the
best match from your list in order of preference of your prefix. A
prefix can either be a numeric barcode stem, or a 2 letter country code,
which will be expanded into the list of current barcode stems available
to that country.

e.g. if you have a list of 10 barcodes for the same product
internationally, and would prefer the UK barcode if it exists, otherwise
the Irish one, otherwise any valid barcode, you would call:

  my $best_barcode = best_barcode(\@barcodes, ["uk", "ie"]);

If there are no valid barcodes in your list this will return the first
barcode which would be valid if it was zero-padded, or null if none
meet this final criterion.

=cut

sub best_barcode {
	my $bref = shift;
	my $pref_ref = shift || [];
	_build_prefix() unless %prefix;
	my @prefs = map { @{ $prefix{$_} || [$_] } } @$pref_ref;

	my $best = "";
	my @invalids;
	BARCODE: foreach my $barcode (@$bref) {
		unless (valid_barcode($barcode)) {
			push @invalids => $barcode if (length $barcode < 13);
			next BARCODE;
		}

		# if we have no conditions, then any valid match wins ...
		return $barcode unless @prefs;
		PREF: foreach my $pref (0 .. @prefs - 1) {
			next PREF unless ($barcode =~ /^$prefs[$pref]/);
			return $barcode if ($pref == 0);
			$best = $barcode;
			splice @prefs, $pref;
			next BARCODE;
		}
		$best = $barcode;
	}

	# We have no valid matches, so check the invalids.
	# We should really check the preferences again here,
	# perhaps with something like:
	#  return $best if $best;
	#  return undef unless @invalids;
	#  my @padded = map { sprintf "%013s", $_ }, @invalids;
	#  return best_barcode(\@padded);

	unless ($best) {
		foreach my $barcode (@invalids) {
			$barcode = sprintf "%013s", $barcode;
			next unless valid_barcode($barcode);
			$best = $barcode;
			last;
		}
	}
	return $best || undef;
}

=head1 BUGS

When zero-filling the barcodes in "best_barcode" we should re-apply the
preferences again, rather than just taking the first valid barcode.

=head1 TODO

Allow other barcode families than EAN-13

=head1 AUTHOR

Colm Dougan, Tony Bowden and Jan Willamowius (https://www.ean-search.org)

=head1 LICENSE

This program may be distributed under the same license as Perl itself.

=cut

return q/
  i don't want the world i just want your half
/;

# Here lies the mapping data from country to barcode-prefix.
__DATA__