Barcode::RM4SCC - Generate Royal Mail 4 State Customer Code (RM4SCC) barcodes and barcode data

	use Barcode::RM4SCC;
	my $obj = new Barcode::RM4SCC( String => 'WC1E6XY' );
	my $pattern = $obj->barcode;

	my $gdObj = $obj->plot;
	# or specify some options:
	# my $gdObj = $obj->plot( WithText => 1, QuietZone => 10);
	my $image = $gdObj->png;

	open(IMG, ">$aFilename") || die "Cannot open $aFilename: $!";
	binmode(IMG);
	print IMG $image;
	close(IMG);

package Barcode::RM4SCC;
use strict;

use constant DEFAULT_QUIET => 8;
# From examining real barcodes the bars seem to be 1 unit wide,
# followed by 1 unit of space. The track is 2 units high. The ascender
# is 4 to 4.5 units high and the descender is 4 units high.
# To get whole numbers and to make the image a more sensible size I use 2 pixels for 1 unit
use constant H_ASCENDER => 9;
use constant H_TRACK => 4;
use constant H_DESCENDER => 8;
use constant W_BAR => 2;

use vars qw($VERSION %CHARSET %CODEDCHARSET $START $STOP %BITLUT @CHECKLUT);
($VERSION) = ('$Revision: 1.5 $' =~ /([\d\.]+)/ );

# the character-to-symbol mapping in a relatively readable form
%CHARSET = (
	"0" => "--||",
	"1" => "-.'|",
	"2" => "-.|'",
	"3" => ".-'|",
	"4" => ".-|'",
	"5" => "..''",
	"6" => "-'.|",
	"7" => "-|-|",
	"8" => "-|.'",
	"9" => ".'-|",
	"A" => ".'.'",
	"B" => ".|-'",
	"C" => "-'|.",
	"D" => "-|'.",
	"E" => "-||-",
	"F" => ".''.",
	"G" => ".'|-",
	"H" => ".|'-",
	"I" => "'-.|",
	"J" => "'.-|",
	"K" => "'..'",
	"L" => "|--|",
	"M" => "|-.'",
	"N" => "|.-'",
	"O" => "'-|.",
	"P" => "'.'.",
	"Q" => "'.|-",
	"R" => "|-'.",
	"S" => "|-|-",
	"T" => "|.'-",
	"U" => "''..",
	"V" => "'|-.",
	"W" => "'|.-",
	"X" => "|'-.",
	"Y" => "|'.-",
	"Z" => "||--",
);

# other static data
$START = "'";
$STOP = "|";
%BITLUT = (
	"-" => 0,
	"." => 1,
	"'" => 2,
	"|" => 3,
);
@CHECKLUT = (
	[ qw(Z U V W X Y) ],
	[ qw(5 0 1 2 3 4) ],
	[ qw(B 6 7 8 9 A) ],
	[ qw(H C D E F G) ],
	[ qw(N I J K L M) ],
	[ qw(T O P Q R S) ],
);


_initialize();

### PUBLIC INTERFACE #####################################

sub new {
	my ($class, %options) = @_;
	
	my $str = $options{'String'};
	die "You must supply a string to make the barcode from using the 'String' constructor option" unless (defined($str) && length($str));
	my $cleanstr = _sanitize($str);
	die "The supplied string '$str' contained no allowable characters" unless (defined($cleanstr) && length($cleanstr));
	my $self = {
		string => $str,
		cleanstring => $cleanstr,
		checkchar => _checksum($cleanstr),
		nochecksum => ($options{'NoChecksum'} || 0),
		nostartbit => ($options{'NoStartbit'} || 0),
		nostopbit => ($options{'NoStopbit'} || 0),
	};
	DUMP($self);
	return bless $self, $class;
}

sub barcode {
	my $self = shift;
	my $pattern = '';
	unless ($self->{'nostartbit'}) { $pattern .= $BITLUT{$START}; }
	foreach my $c (split '', $self->{'cleanstring'}) {
		my $bars = $CODEDCHARSET{$c} || die "Internal Error: Cannot find symbol for character '$c'";
		$pattern .= join('', @$bars);
	}
	unless ($self->{'nochecksum'}) {
		my $bars = $CODEDCHARSET{$self->{'checkchar'}} || die "Internal Error: Cannot find symbol for character '$self->{'checkchar'}'";
		$pattern .= join('', @$bars);
	}
	unless ($self->{'nostopbit'}) { $pattern .= $BITLUT{$STOP}; }
	
	return $pattern;
}

sub plot {	
	my ($self, %options) = @_;

	eval {
		require GD;
		import GD;
	};
	if ($@) {
		my $err = $@;
		$err =~ s/[\r\n]/ /g;
		die "Cannot plot() barcodes: Unable to load the GD graphics library: $err\n";
	}

	my $pattern = $self->barcode;
	my $nbars = length($pattern);
	my $quiet = DEFAULT_QUIET;
	if (defined $options{'QuietZone'}) {
		$quiet = $options{'QuietZone'};
	}
	my $main_w = 2 * W_BAR * $nbars;
	my $main_h = H_ASCENDER + H_TRACK + H_DESCENDER + ($options{'WithText'} ? 14 : 0);
	
	my $gd = GD::Image->new(2*$quiet+$main_w, 2*$quiet+$main_h);
	my $bgcolourdef = $options{'BGColour'} || [255, 255, 255];
	my $fgcolourdef = $options{'BarColour'} || [0, 0, 0];
	
	my $bg_col = $gd->colorAllocate( @$bgcolourdef );
	my $fg_col = $gd->colorAllocate( @$fgcolourdef );
	if ($options{'BGTransparent'}) {
		$gd->transparent($bg_col);
	}

	for my $i (0..$nbars-1) {
		my $x = $quiet + ($i * 2 * W_BAR);
		my $bar = substr($pattern, $i, 1);
		my ($top, $bottom) = (0, 0);
		if ($bar & 1) {
			$bottom = H_ASCENDER + H_TRACK + H_DESCENDER - 1; # remove 1 because pixel numbering is zero-based
		} else {
			$bottom = H_ASCENDER + H_TRACK - 1;
		}
		if ($bar & 2) {
			$top = 0;
		} else {
			$top = H_ASCENDER;
		}
		$gd->filledRectangle($x, $quiet+$top, $x+W_BAR-1, $quiet+$bottom, $fg_col);
	}
	
	if ($options{'WithText'}) {
		$gd->string(gdSmallFont(), $quiet, 2*$quiet+H_ASCENDER+H_TRACK+H_DESCENDER, $self->{'cleanstring'}, $fg_col);
	}
	
	return $gd;
}

### PRIVATE ROUTINES #####################################

# given a string of data, strip out anything not in the character set and correct case
sub _sanitize {
	my $str = uc(shift);
	my $set = join '', keys %CHARSET;
	$str =~ s/[^$set]//g;
	return $str;
}

# given a string of data, return the check character
sub _checksum {
	my $str = _sanitize(shift);
	die "You must supply a string to get the checksum of" unless (length $str);
	my @chars = split '', $str;
	
	my ($lowertotal, $uppertotal) = (0, 0);
	foreach my $c (@chars) {
		TRACE("_checksum: adding '$c'");
		my $bars = $CODEDCHARSET{$c} || die "Internal Error: Cannot find symbol for character '$c'";
		my ($l_lower, $l_upper) = (0, 0);

		if ($bars->[0] & 1) { $l_lower += 4; }
		if ($bars->[1] & 1) { $l_lower += 2; }
		if ($bars->[2] & 1) { $l_lower += 1; }
		if ($bars->[0] & 2) { $l_upper += 4; }
		if ($bars->[1] & 2) { $l_upper += 2; }
		if ($bars->[2] & 2) { $l_upper += 1; }

		TRACE("_checksum: Char: lower $l_lower upper $l_upper");
		$lowertotal += ($l_lower % 6);
		$uppertotal += ($l_upper % 6);
	}
	$lowertotal %= 6;
	$uppertotal %= 6;
	TRACE("_checksum: Total: lower $lowertotal upper $uppertotal");
	
	my $checkchar = $CHECKLUT[$uppertotal][$lowertotal];
	TRACE("_checksum: Result '$checkchar'");
	return $checkchar;
}

sub _initialize {
	my %duplicates;
	foreach my $k (sort keys %CHARSET) {
		my $v = $CHARSET{$k};
		
		# check the main data tables
		unless ($v =~ m/^[\.\-\'\|]{4}$/) {
			die "Internal Error: Character '$k' does not have a valid definition - '$v' is of the wrong format";
		}
		die "Internal Error: Character '$k' duplicates the symbol definition of '$duplicates{$v}'" if $duplicates{$v};
		$duplicates{$v} = $k;
		
		# encode the data in a binary form
		my @bars;
		foreach my $c (split '', $v) {
			push @bars, $BITLUT{$c};
		}
		$CODEDCHARSET{$k} = \@bars;
	}
}

# These are debugging hooks
sub TRACE {}
sub DUMP {}

1;