#!/usr/local/bin/perl -w
#
# This software has been created by Genome Research Limited (GRL). 
# GRL hereby grants permission to use, copy, modify and distribute 
# this software and its documentation for non-commercial purposes 
# without fee at the user's own risk on the basis set out below.
# GRL neither undertakes nor accepts any duty whether contractual or 
# otherwise in connection with the software, its use or the use of 
# any derivative, and makes no representations or warranties, express
# or implied, concerning the software, its suitability, fitness for
# a particular purpose or non-infringement.
# In no event shall the authors of the software or GRL be responsible 
# or liable for any loss or damage whatsoever arising in any way 
# directly or indirectly out of the use of this software or its 
# derivatives, even if advised of the possibility of such damage.
# Our software can be freely distributed under the conditions set out 
# above, and must contain this copyright notice.


package Checkbarcode;

use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
use Exporter;
$VERSION = 1.01;
@ISA = qw(Exporter);

@EXPORT = qw(&Verifynumber &makeID &Calculatebarcode);

sub makeID {
my $pkg = shift;
my $s;

if(! ref $pkg)
{$s = $pkg;}else{ ($s) = @_;}

  return $s =~ /^[A-Z][A-Z][1-9][0-9]*$/ ? $s . makeCheck($s) : "";
}

sub IdOrNull {
    my ($s, $type) = @_;
    return validID($s, $type) ? substr($s, 2, -1) : "NULL";
}

sub validID {
    my ($s, $type) = @_;
    return "" if $s !~ /^[A-Z][A-Z][1-9][0-9]*[A-Z]$/;
    if (defined $type) {
    #Modified to return NULL on type miss match
	return "NULL" if $type ne substr($s, 0, 2);
    }
    
    my $ck = substr($s, length($s) - 1, 1);
    return $ck eq makeCheck(substr($s, 0, -1));
}

sub makeCheck {
    my ($s) = @_;
    my @chars = split //, $s;

    my $len = scalar @chars;
    my $sum = 0;
    foreach my $c (@chars) {
	$sum += ord($c) * $len--;
    }
    return chr($sum % 23 + ord('A'));
}

sub Verifynumber {
my $pkg = shift;
my $code;
my $type;
my $prefix = "Not Determined";
my $number;
my $check = "Not Determined";
my $sanger = '';
my $s;
my $strip;
my $p;


if(! ref $pkg)
{
	$code = $pkg;
	$type = shift;
	$code = "$code";
}
else
{
	($code,$type) = @_;
	$code = "$code";
}

$number = $code;
if($code !~ /\D/g)
{

	# Code128 work around

	if((length($code) == 10)||(length($code) == 11))
	{
	# Then we are talking code128. Need to convert to EAN13 format
	
	while(length($code) < 11){$code = "0$code";}
	
	$code = substr($code,0,3).'0'.substr($code,3).'0';
	
	}

	if((length($code) > 11)&&(length($code) < 14))
	{
	# For code 128 formats that have only 12 digits
		while(length($code) < 13){$code = "0$code";}
		$number 	= substr($code,0,12);
				
		$check	 	= chr(substr($number,10));
				
		$prefix		= &Letter_prefix(substr($number,0,3));
		$number		= substr($number,3,7)/1;
		$code = "$prefix$number$check";
		my $r = validID($code,$type);
		if ($r eq "NULL")	{$p = "Invalid"	;}
		elsif(!$r)		{$p = "Bad"	;}
		else			{$p = "Good"	;}

		return {	Process => $p, 
				Type 	=> $prefix, 
				Number 	=> $number, 
				Check 	=> $check,
				Whole 	=> $code
			};
	}
}
	
$check = validID($code,$type);
if ($check eq "NULL")	{	$p = "Invalid"	;}
elsif(!$check)		{	$p = "Bad"	;}
else			{	$p = "Good"	;}

if($p ne "Bad")
{
	$prefix = substr($code,0,2);
	$number = substr($code,2,(length($code)-3));
	$check 	= substr($code,length($code)-1);
}



return {	Process => $p, 
		Type 	=> $prefix, 
		Number 	=> $number, 
		Check 	=> $check,
		Whole 	=> $code
	};				

}



sub Number_prefix {
# Return the number of two letter prefix
my ($prefix) = @_;
my $i;
my $j;

$i = (substr $prefix,0,1);
$j = (substr $prefix,1,1);

$i = ord($i)-64;
$j = ord($j)-64;
if($i < 1){$i = 0;}
if($j < 1){$j = 0;}


$prefix = (($i * 27) + $j) * 1000000000;

return $prefix;
}



sub Letter_prefix {
# Return two letter prefix given a number
my ($prefix) = @_;
my $i;
my $j;
$i = int($prefix/27);
$j = $prefix%27;

if($i != 0){$i = chr($i + 64);}
if($j != 0){$j = chr($j + 64);}
return ("$i$j");
}



sub Calculatebarcode {
my ($type,$number) = @_;

if((!$number)||($number < 1)){return ('000000000000','0');}

my $cl = &makeID("$type$number");
if(!$cl){return (-1);}

my $bc = &Number_prefix($type) + ($number * 100);
$bc += ord(substr($cl,length($cl)-1));
if(length($bc) == 11){$bc ="0$bc";}
$number = $cl;
return ($bc, $number);
}

1;
