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

  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);

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

package Business::Barcode::EAN13;

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     = "1.01";

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

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

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

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;
}

#--------------------------------------------------------------------------
# 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}$/);
}

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 "";
}

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;
}

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

# Here lies the mapping data from country to barcode-prefix.
__DATA__
us:'00'..'19'
fr:30..37
bg:380
si:383
hr:385
ba:387
de:400..440
jp:45,49
ru:430..439
tw:471
ee:474
lv:475
az:476
lt:477
uz:478
lk:479
ph:480
by:481
ua:482
md:484
am:485
ge:486
kz:487
hk:489
uk:50
gr:520
lb:528
cy:529
mk:531
mt:535
ie:539
be:54
lu:54
pt:560
is:569
dk:57
pl:590
ro:594
hu:599
za:600,601
mu:609
ma:611
dz:613
ke:616
tn:619
sy:621
eg:622
jo:625
ir:626
sa:628
fi:64
cn:690..693
no:70
il:729
se:73
gt:740
sv:741
hn:742
ni:743
cr:744
pa:745
do:746
mx:750
ve:759
ch:76
co:770
uy:773
pe:775
bo:777
ar:779
cl:780
py:784
ec:786
br:789
it:80..83
es:84
cu:850
sk:858
cz:859
yu:860
kp:867
tr:869
nl:87
kr:880
th:885
sg:888
in:890
vn:893
id:899
at:90,91
au:93
nz:94
my:955
mo:958