#!/usr/local/bin/perl -w
#
# Barcode.pm
#
# Version 1.1, 23-DEC-1998
#
# Copyright 1998 Marc Liyanage <liyanage@access.ch>
#
#
use GD;
use strict;


package Barcode;






sub set_module_width {

	my($self, $new_module_width) = @_;

	unless (ref($self)) {
		print STDERR "Barcode::set_module_width(): This method must be called as instance method!\n";
		return 0;
	}

	unless ($new_module_width > 0 and $new_module_width <= 10) {

		print STDERR "Barcode::set_module_width(): Width argument must be > 1 and < 11!\n";
		return 0;
	}

	$self->{'module_width'} = $new_module_width;

	return 1;
}

sub set_barcode_height {

	my($self, $new_barcode_height) = @_;
	
	unless (ref($self)) {
		print STDERR "Barcode::set_barcode_height(): This method must be called as instance method!\n";
		return 0;
	}

	unless ($new_barcode_height > 0 and $new_barcode_height <= 500) {
		print STDERR "Barcode::set_barcode_height(): Width argument must be > 1 and < 11!\n";
		return 0;
	}

	$self->{'barcode_height'} = $new_barcode_height;

	return 1;
}


sub _new {

	my(%state) = (
		inputstring => "",
		module_width => 1,
		barcode_height => 30,
		code_sequence => []
	);

	return \%state;

}



sub _count_modules {

	my($self) = @_;
	
	unless (ref($self)) {
		print STDERR "Barcode::_count_modules(): This method must be called as instance method!\n";
		return 0;
	}
	
	my($current_code, $module_count);
	
	foreach $current_code (@{$self->{code_sequence}}) {
		$module_count += (split(/-/, $current_code))[1];	
	}

	return($module_count);

}




sub as_PNG {

	my($self) = @_;

	unless (ref($self)) {
		print STDERR "Barcode::as_PNG(): This method must be called as instance method!\n";
		return 0;
	}
	
	my($barcode_width) = ($self->_count_modules() * $self->{module_width});
	my($BARCODE_HEIGHT) = $self->{barcode_height};
	
				
	# Create a new Image for the barcode using the width/height values
	# we calculated/got above
	#
	my($barcode_image) = new GD::Image($barcode_width, $BARCODE_HEIGHT);
	
	unless ($barcode_image) {
	
		print STDERR "Barcode::as_PNG(): Unable to create new GD image, aborting!\n";
		return(0);
	}
	
	my($color_space) = $barcode_image->colorAllocate(255,255,255);	# foreground color, barcode space
	my($color_bar) = $barcode_image->colorAllocate(0,0,0);		# background color, barcode bar
	
	
	my($offset_y) = 0;
	my($current_element);
	my($type, $width, $color);

	# Step through all patterns as stored by the _encode method.
	# A pattern looks like this:
	# B-2, S-1, B-3 etc.
	# B means "Bar", S means "Space" and the number is the
	# number of modules (slots), i.e. the width of the space
	# or bar
	#
	foreach $current_element (@{$self->{code_sequence}}) {
		
		# split type and width at - char
		#
		($type, $width) = split(/-/, $current_element);
		$width *= $self->{module_width};	# Multiply with desired module width
		
		# Pick the right color
		#
		$color = ($type eq "B" ? $color_bar : $color_space);

		# Draw a filled rectangle for this bar or space
		#
#		$DEBUG && print "x1 -> $offset_y, y1 -> 0, x2 -> " . (($offset_y + $width) - 1) . ", y2 -> $BARCODE_HEIGHT, color -> $color\n";
		$barcode_image->filledRectangle($offset_y, 0, (($offset_y + $width) - 1), $BARCODE_HEIGHT-1, $color);

		# add width to the offset from left edge
		#
		$offset_y += $width;
		
	}
	
	
	return($barcode_image->png());

}



sub as_PostScript {


	my($self) = @_;

	unless (ref($self)) {
		print STDERR "Barcode::as_PostScript(): This method must be called as instance method!\n";
		return 0;
	}
	

	my($barcode_width) = ($self->_count_modules() * $self->{module_width});
	my($BARCODE_HEIGHT) = $self->{barcode_height};
	

	my($ps_code) = "";
	$ps_code .= "%!PS-Adobe-3.0 EPSF-3.0\n";
	$ps_code .= "%%BoundingBox 0 0 $barcode_width $BARCODE_HEIGHT\n";
	$ps_code .= "%%Creator: Barcode.pm (http://www.entropy.ch/software/)\n";
	$ps_code .= "%%Title: Barcode for \"$self->{inputstring}\"\n";


	my($offset_y) = 0;
	my($current_element);
	my($type, $width, $color);
	my($x1, $y1, $x2, $y2);

	# Step through all patterns as stored by the _encode method.
	# A pattern looks like this:
	# B-2, S-1, B-3 etc.
	# B means "Bar", S means "Space" and the number is the
	# number of modules (slots), i.e. the width of the space
	# or bar
	#
	foreach $current_element (@{$self->{code_sequence}}) {
		
		# split type and width at - char
		#
		($type, $width) = split(/-/, $current_element);
		$width *= $self->{module_width};	# Multiply with desired module width

		$color = ($type eq "B" ? "0" : "1");

		$x1 = $offset_y;
		$x2 = ($offset_y + $width);
		$y1 = 0;
		$y2 = $BARCODE_HEIGHT;

		$ps_code .= "$color setgray\n";
		$ps_code .= "$x1 $y1 moveto\n";
		$ps_code .= "$x1 $y2 lineto\n";
		$ps_code .= "$x2 $y2 lineto\n";
		$ps_code .= "$x2 $y1 lineto\n";
		$ps_code .= "closepath\n";
		$ps_code .= "fill\n";
		
		# add width to the offset from left edge
		#
		$offset_y += $width;
		
	}
	
	
	return($ps_code);

}









# This is based on information from
#
# http://www.hp.com/HP-COMP/barcode/sg/Misc/code_128.html
#
# Note that we only use the CODE B encoding,
# with SHIFT CODE A escapes for the chars < ASCII 30.
#
package Barcode::Barcode128;

@Barcode::Barcode128::ISA = qw( Barcode );


sub new_from_string {
	
	# Check if the input string has at least one 7-bit ASCII character
	#
	my ($self, $barcode_data) = @_;
	unless ($barcode_data =~ /[\x00-\x7F]/) {
	
		print STDERR "Barcode::Barcode128::new_from_string(): First argument must be a string with at least one 7-bit ASCII character!\n";
		return 0;
	}

	my $state = $self->_new();


	unless (ref($state)) {
		return 0;
	}

	$state->{'inputstring'} = $barcode_data;
	
	bless $state, $self;

	$state->_encode();
	
	return $state;

}




sub _encode {

	my ($self) = @_;

	unless (ref($self)) {
		print STDERR "Barcode::Barcode128::_encode(): This method must be called as instance method!\n";
		return 0;
	}

	my($barcode_data) = $self->{inputstring};

	my($table) = $Barcode::Barcode128::table;
	
	# What character should we substitute for unknown input characters?
	#
	$Barcode::Barcode128::SUBSTITUTION_CHAR = '?';
	
	
	# How long is the input string?
	#
	my($data_length) = length($barcode_data);
	
	# The array @barcode_code will hold all the codes for this
	# barcode. We begin by putting the START sequence in it.
	#
	my(@barcode_codes) = ($table->{'control2codes'}->{'START_CODE_B'});

	# Now step though all the chars in the input string from left to right
	#
	my($index) = 0;
	my($substitutions) = 0;
	my($character);
	
	while ($index < $data_length) {
	
		# Read one character
		#
		$character = substr($barcode_data, $index, 1);
	
		# Is this a known character, i.e. do we have a mapping to a
		# code value in our tables?
		#
		unless (exists($table->{'characters2codes'}->{$character})) {
	
			# No we don't, use substitution character.
			#
			$character = $Barcode::Barcode128::SUBSTITUTION_CHAR;
			
			$substitutions = 1;
		}
	
	
	
		# Now we're sure to have a known character.
		# Get the code sequence array from the characters2codes table and append
		# it to the @barcode_codes array.
		#
		push @barcode_codes, @{$table->{'characters2codes'}->{$character}};

		# OK, advance one position
		#
		$index++;
	}
	
	
	# Calculate the checksum, begin with the code value of the START character
	#
	my($barcode_checksum) = $barcode_codes[0];
	
	# Now add the code value of every character
	# weighted by its position in the array
	#
	for ($index = 1; $index < scalar(@barcode_codes); $index++) {
		$barcode_checksum += ($index * $barcode_codes[$index]);
	}
	
	# The checksum is the sum we just calculated modulo 103
	#
	$barcode_checksum %= 103;
	
	
	# Push checksum and STOP character onto stack
	#
	push @barcode_codes, $barcode_checksum;
	push @barcode_codes, $table->{'control2codes'}->{'STOP'};
	
	my($current_code);

	while (defined($current_code = shift(@barcode_codes))) {
	
		push @{$self->{code_sequence}}, @{$table->{'codes2patterns'}->{$current_code}};
		
	}

	return($substitutions);

}





my(%characters2codes) = (

	' ' => [0],
	'!' => [1],
	'"' => [2],
	'#' => [3],
	'$' => [4],
	'%' => [5],
	'&' => [6],
	"'" => [7],
	'(' => [8],
	')' => [9],
	'*' => [10],
	'+' => [11],
	',' => [12],
	'-' => [13],
	'.' => [14],
	'/' => [15],
	'0' => [16],
	'1' => [17],
	'2' => [18],
	'3' => [19],
	'4' => [20],
	'5' => [21],
	'6' => [22],
	'7' => [23],
	'8' => [24],
	'9' => [25],
	':' => [26],
	';' => [27],
	'<' => [28],
	'=' => [29],
	'>' => [30],
	'?' => [31],
	'@' => [32],
	'A' => [33],
	'B' => [34],
	'C' => [35],
	'D' => [36],
	'E' => [37],
	'F' => [38],
	'G' => [39],
	'H' => [40],
	'I' => [41],
	'J' => [42],
	'K' => [43],
	'L' => [44],
	'M' => [45],
	'N' => [46],
	'O' => [47],
	'P' => [48],
	'Q' => [49],
	'R' => [50],
	'S' => [51],
	'T' => [52],
	'U' => [53],
	'V' => [54],
	'W' => [55],
	'X' => [56],
	'Y' => [57],
	'Z' => [58],
	'[' => [59],
	"\\" => [60],
	']' => [61],
	'^' => [62],
	'_' => [63],
	'`' => [64],
	'a' => [65],
	'b' => [66],
	'c' => [67],
	'd' => [68],
	'e' => [69],
	'f' => [70],
	'g' => [71],
	'h' => [72],
	'i' => [73],
	'j' => [74],
	'k' => [75],
	'l' => [76],
	'm' => [77],
	'n' => [78],
	'o' => [79],
	'p' => [80],
	'q' => [81],
	'r' => [82],
	's' => [83],
	't' => [84],
	'u' => [85],
	'v' => [86],
	'w' => [87],
	'x' => [88],
	'y' => [89],
	'z' => [90],
	'{' => [91],
	'|' => [92],
	'}' => [93],
	'~' => [94],
	"\x7F" => [95],
	
	"\x00" => [98, 64],
	"\x01" => [98, 65],
	"\x02" => [98, 66],
	"\x03" => [98, 67],
	"\x04" => [98, 68],
	"\x05" => [98, 69],
	"\x06" => [98, 70],
	"\x07" => [98, 71],
	"\x08" => [98, 72],
	"\x09" => [98, 73],
	"\x0A" => [98, 74],
	"\x0B" => [98, 75],
	"\x0C" => [98, 76],
	"\x0D" => [98, 77],
	"\x0E" => [98, 78],
	"\x0F" => [98, 79],
	"\x10" => [98, 80],
	"\x11" => [98, 81],
	"\x12" => [98, 82],
	"\x13" => [98, 83],
	"\x14" => [98, 84],
	"\x15" => [98, 85],
	"\x16" => [98, 86],
	"\x17" => [98, 87],
	"\x18" => [98, 88],
	"\x19" => [98, 89],
	"\x1A" => [98, 90],
	"\x1B" => [98, 91],
	"\x1C" => [98, 92],
	"\x1D" => [98, 93],
	"\x1E" => [98, 94],
	"\x1F" => [98, 95]

);


my(%codes2patterns) = (

	0 => ['B-2', 'S-1', 'B-2', 'S-2', 'B-2', 'S-2'],
	1 => ['B-2', 'S-2', 'B-2', 'S-1', 'B-2', 'S-2'],
	2 => ['B-2', 'S-2', 'B-2', 'S-2', 'B-2', 'S-1'],
	3 => ['B-1', 'S-2', 'B-1', 'S-2', 'B-2', 'S-3'],
	4 => ['B-1', 'S-2', 'B-1', 'S-3', 'B-2', 'S-2'],
	5 => ['B-1', 'S-3', 'B-1', 'S-2', 'B-2', 'S-2'],
	6 => ['B-1', 'S-2', 'B-2', 'S-2', 'B-1', 'S-3'],
	7 => ['B-1', 'S-2', 'B-2', 'S-3', 'B-1', 'S-2'],
	8 => ['B-1', 'S-3', 'B-2', 'S-2', 'B-1', 'S-2'],
	9 => ['B-2', 'S-2', 'B-1', 'S-2', 'B-1', 'S-3'],
	10 => ['B-2', 'S-2', 'B-1', 'S-3', 'B-1', 'S-2'],
	11 => ['B-2', 'S-3', 'B-1', 'S-2', 'B-1', 'S-2'],
	12 => ['B-1', 'S-1', 'B-2', 'S-2', 'B-3', 'S-2'],
	13 => ['B-1', 'S-2', 'B-2', 'S-1', 'B-3', 'S-2'],
	14 => ['B-1', 'S-2', 'B-2', 'S-2', 'B-3', 'S-1'],
	15 => ['B-1', 'S-1', 'B-3', 'S-2', 'B-2', 'S-2'],
	16 => ['B-1', 'S-2', 'B-3', 'S-1', 'B-2', 'S-2'],
	17 => ['B-1', 'S-2', 'B-3', 'S-2', 'B-2', 'S-1'],
	18 => ['B-2', 'S-2', 'B-3', 'S-2', 'B-1', 'S-1'],
	19 => ['B-2', 'S-2', 'B-1', 'S-1', 'B-3', 'S-2'],
	20 => ['B-2', 'S-2', 'B-1', 'S-2', 'B-3', 'S-1'],
	21 => ['B-2', 'S-1', 'B-3', 'S-2', 'B-1', 'S-2'],
	22 => ['B-2', 'S-2', 'B-3', 'S-1', 'B-1', 'S-2'],
	23 => ['B-3', 'S-1', 'B-2', 'S-1', 'B-3', 'S-1'],
	24 => ['B-3', 'S-1', 'B-1', 'S-2', 'B-2', 'S-2'],
	25 => ['B-3', 'S-2', 'B-1', 'S-1', 'B-2', 'S-2'],
	26 => ['B-3', 'S-2', 'B-1', 'S-2', 'B-2', 'S-1'],
	27 => ['B-3', 'S-1', 'B-2', 'S-2', 'B-1', 'S-2'],
	28 => ['B-3', 'S-2', 'B-2', 'S-1', 'B-1', 'S-2'],
	29 => ['B-3', 'S-2', 'B-2', 'S-2', 'B-1', 'S-1'],
	30 => ['B-2', 'S-1', 'B-2', 'S-1', 'B-2', 'S-3'],
	31 => ['B-2', 'S-1', 'B-2', 'S-3', 'B-2', 'S-1'],
	32 => ['B-2', 'S-3', 'B-2', 'S-1', 'B-2', 'S-1'],
	33 => ['B-1', 'S-1', 'B-1', 'S-3', 'B-2', 'S-3'],
	34 => ['B-1', 'S-3', 'B-1', 'S-1', 'B-2', 'S-3'],
	35 => ['B-1', 'S-3', 'B-1', 'S-3', 'B-2', 'S-1'],
	36 => ['B-1', 'S-1', 'B-2', 'S-3', 'B-1', 'S-3'],
	37 => ['B-1', 'S-3', 'B-2', 'S-1', 'B-1', 'S-3'],
	38 => ['B-1', 'S-3', 'B-2', 'S-3', 'B-1', 'S-1'],
	39 => ['B-2', 'S-1', 'B-1', 'S-3', 'B-1', 'S-3'],
	40 => ['B-2', 'S-3', 'B-1', 'S-1', 'B-1', 'S-3'],
	41 => ['B-2', 'S-3', 'B-1', 'S-3', 'B-1', 'S-1'],
	42 => ['B-1', 'S-1', 'B-2', 'S-1', 'B-3', 'S-3'],
	43 => ['B-1', 'S-1', 'B-2', 'S-3', 'B-3', 'S-1'],
	44 => ['B-1', 'S-3', 'B-2', 'S-1', 'B-3', 'S-1'],
	45 => ['B-1', 'S-1', 'B-3', 'S-1', 'B-2', 'S-3'],
	46 => ['B-1', 'S-1', 'B-3', 'S-3', 'B-2', 'S-1'],
	47 => ['B-1', 'S-3', 'B-3', 'S-1', 'B-2', 'S-1'],
	48 => ['B-3', 'S-1', 'B-3', 'S-1', 'B-2', 'S-1'],
	49 => ['B-2', 'S-1', 'B-1', 'S-3', 'B-3', 'S-1'],
	50 => ['B-2', 'S-3', 'B-1', 'S-1', 'B-3', 'S-1'],
	51 => ['B-2', 'S-1', 'B-3', 'S-1', 'B-1', 'S-3'],
	52 => ['B-2', 'S-1', 'B-3', 'S-3', 'B-1', 'S-1'],
	53 => ['B-2', 'S-1', 'B-3', 'S-1', 'B-3', 'S-1'],
	54 => ['B-3', 'S-1', 'B-1', 'S-1', 'B-2', 'S-3'],
	55 => ['B-3', 'S-1', 'B-1', 'S-3', 'B-2', 'S-1'],
	56 => ['B-3', 'S-3', 'B-1', 'S-1', 'B-2', 'S-1'],
	57 => ['B-3', 'S-1', 'B-2', 'S-1', 'B-1', 'S-3'],
	58 => ['B-3', 'S-1', 'B-2', 'S-3', 'B-1', 'S-1'],
	59 => ['B-3', 'S-3', 'B-2', 'S-1', 'B-1', 'S-1'],
	60 => ['B-3', 'S-1', 'B-4', 'S-1', 'B-1', 'S-1'],
	61 => ['B-2', 'S-2', 'B-1', 'S-4', 'B-1', 'S-1'],
	62 => ['B-4', 'S-3', 'B-1', 'S-1', 'B-1', 'S-1'],
	63 => ['B-1', 'S-1', 'B-1', 'S-2', 'B-2', 'S-4'],
	64 => ['B-1', 'S-1', 'B-1', 'S-4', 'B-2', 'S-2'],
	65 => ['B-1', 'S-2', 'B-1', 'S-1', 'B-2', 'S-4'],
	66 => ['B-1', 'S-2', 'B-1', 'S-4', 'B-2', 'S-1'],
	67 => ['B-1', 'S-4', 'B-1', 'S-1', 'B-2', 'S-2'],
	68 => ['B-1', 'S-4', 'B-1', 'S-2', 'B-2', 'S-1'],
	69 => ['B-1', 'S-1', 'B-2', 'S-2', 'B-1', 'S-4'],
	70 => ['B-1', 'S-1', 'B-2', 'S-4', 'B-1', 'S-2'],
	71 => ['B-1', 'S-2', 'B-2', 'S-1', 'B-1', 'S-4'],
	72 => ['B-1', 'S-2', 'B-2', 'S-4', 'B-1', 'S-1'],
	73 => ['B-1', 'S-4', 'B-2', 'S-1', 'B-1', 'S-2'],
	74 => ['B-1', 'S-4', 'B-2', 'S-2', 'B-1', 'S-1'],
	75 => ['B-2', 'S-4', 'B-1', 'S-2', 'B-1', 'S-1'],
	76 => ['B-2', 'S-2', 'B-1', 'S-1', 'B-1', 'S-4'],
	77 => ['B-4', 'S-1', 'B-3', 'S-1', 'B-1', 'S-1'],
	78 => ['B-2', 'S-4', 'B-1', 'S-1', 'B-1', 'S-2'],
	79 => ['B-1', 'S-3', 'B-4', 'S-1', 'B-1', 'S-1'],
	80 => ['B-1', 'S-1', 'B-1', 'S-2', 'B-4', 'S-2'],
	81 => ['B-1', 'S-2', 'B-1', 'S-1', 'B-4', 'S-2'],
	82 => ['B-1', 'S-2', 'B-1', 'S-2', 'B-4', 'S-1'],
	83 => ['B-1', 'S-1', 'B-4', 'S-2', 'B-1', 'S-2'],
	84 => ['B-1', 'S-2', 'B-4', 'S-1', 'B-1', 'S-2'],
	85 => ['B-1', 'S-2', 'B-4', 'S-2', 'B-1', 'S-1'],
	86 => ['B-4', 'S-1', 'B-1', 'S-2', 'B-1', 'S-2'],
	87 => ['B-4', 'S-2', 'B-1', 'S-1', 'B-1', 'S-2'],
	88 => ['B-4', 'S-2', 'B-1', 'S-2', 'B-1', 'S-1'],
	89 => ['B-2', 'S-1', 'B-2', 'S-1', 'B-4', 'S-1'],
	90 => ['B-2', 'S-1', 'B-4', 'S-1', 'B-2', 'S-1'],
	91 => ['B-4', 'S-1', 'B-2', 'S-1', 'B-2', 'S-1'],
	92 => ['B-1', 'S-1', 'B-1', 'S-1', 'B-4', 'S-3'],
	93 => ['B-1', 'S-1', 'B-1', 'S-3', 'B-4', 'S-1'],
	94 => ['B-1', 'S-3', 'B-1', 'S-1', 'B-4', 'S-1'],
	95 => ['B-1', 'S-1', 'B-4', 'S-1', 'B-1', 'S-3'],
	96 => ['B-1', 'S-1', 'B-4', 'S-3', 'B-1', 'S-1'],
	97 => ['B-4', 'S-1', 'B-1', 'S-1', 'B-1', 'S-3'],
	98 => ['B-4', 'S-1', 'B-1', 'S-3', 'B-1', 'S-1'],
	99 => ['B-1', 'S-1', 'B-3', 'S-1', 'B-4', 'S-1'],
	100 => ['B-1', 'S-1', 'B-4', 'S-1', 'B-3', 'S-1'],
	101 => ['B-3', 'S-1', 'B-1', 'S-1', 'B-4', 'S-1'],
	102 => ['B-4', 'S-1', 'B-1', 'S-1', 'B-3', 'S-1'],
	
	103 => ['B-2', 'S-1', 'B-1', 'S-4', 'B-1', 'S-2'],
	104 => ['B-2', 'S-1', 'B-1', 'S-2', 'B-1', 'S-4'],
	105 => ['B-2', 'S-1', 'B-1', 'S-2', 'B-3', 'S-2'],
	
	106 => ['B-2', 'S-3', 'B-3', 'S-1', 'B-1', 'S-1', 'B-2']
	
);


my(%control2codes) = (
	'START_CODE_A' => 103,
	'START_CODE_B' => 104,
	'START_CODE_C' => 105,
	'STOP' => 106,		
);

my(%translation_table) = (
	'characters2codes' => \%characters2codes,
	'codes2patterns' => \%codes2patterns,
	'control2codes' => \%control2codes,
);


$Barcode::Barcode128::table = \%translation_table;







1;


__END__

=head1 NAME

Barcode.pm - Create Barcode images in PostScript or PNG

=head1 SYNOPSIS

  use Barcode.pm;

  $my_barcode = Barcode::Barcode128->new_from_string("Barcodes are fun!");

  $postscript_image = $my_barcode->as_PostScript();
  $png_image = $my_barcode->as_PNG();


=head1 DESCRIPTION

This module translates strings to barcode images in PNG or 
PostScript format.

So far only the Barcode128 type is implemented. New types
will be added depending on user requests...

The module depends on the GD.pm Module, which can be found
on CPAN.

=head1 AUTHOR

Marc Liyanage, liyanage@access.ch

=head1 SEE ALSO

HP maintains alot of useful barcode information at

http://www.hp.com/HP-COMP/barcode/sg/Misc/code_128.html

=cut