File Coverage

blib/lib/Crypt/Tea.pm

Criterion	Covered	Total	%
statement	202	216	93.5
branch	36	56	64.2
condition	7	9	77.7
subroutine	20	23	86.9
pod	6	17	35.2
total	271	321	84.4

# Tea.pm
#########################################################################
#        This Perl module is Copyright (c) 2000, Peter J Billam         #
#               c/o P J B Computing, www.pjb.com.au                     #
#                                                                       #
#     This module is free software; you can redistribute it and/or      #
#            modify it under the same terms as Perl itself.             #
#########################################################################
#
# implements TEA, the Tiny Encryption Algorithm, in Perl and Javascript.
# http://www.cl.cam.ac.uk/ftp/papers/djw-rmn/djw-rmn-tea.html
#
# Usage:
#    use Tea;
#    $key = 'PUFgob$*LKDF D)(F IDD&P?/';
#    $ascii_cyphertext = &encrypt ($plaintext, $key);
#    ...
#    $plaintext_again = &decrypt ($ascii_cyphertext, $key);
#    ...
#    $signature = &asciidigest ($text);
#
# The $key is a sufficiently longish string; at least 17 random 8-bit bytes
#
# Written by Peter J Billam, http://www.pjb.com.au

package Crypt::Tea;
$VERSION = '2.12';

# Don't like depending on externals; this is strong encrytion ... but ...
use Exporter; @ISA = qw(Exporter);
@EXPORT=qw(asciidigest encrypt decrypt tea_in_javascript);
@EXPORT_OK = qw(str2ascii ascii2str encrypt_and_write);
%EXPORT_TAGS = (ALL => [@EXPORT,@EXPORT_OK]);

# begin config
my %a2b = (
	A=>000, B=>001, C=>002, D=>003, E=>004, F=>005, G=>006, H=>007,
	I=>010, J=>011, K=>012, L=>013, M=>014, N=>015, O=>016, P=>017,
	Q=>020, R=>021, S=>022, T=>023, U=>024, V=>025, W=>026, X=>027,
	Y=>030, Z=>031, a=>032, b=>033, c=>034, d=>035, e=>036, f=>037,
	g=>040, h=>041, i=>042, j=>043, k=>044, l=>045, m=>046, n=>047,
	o=>050, p=>051, q=>052, r=>053, s=>054, t=>055, u=>056, v=>057,
	w=>060, x=>061, y=>062, z=>063, '0'=>064,  '1'=>065, '2'=>066, '3'=>067,
	'4'=>070,'5'=>071,'6'=>072,'7'=>073,'8'=>074,'9'=>075,'-'=>076,'_'=>077,
);
my %b2a = reverse %a2b;
$a2b{'+'}=076;
# end config

# ------------------ infrastructure ...

sub tea_in_javascript {
	my @js; while () { last if /^EOT$/; push @js, $_; } join '', @js;
}
sub encrypt_and_write { my ($str, $key) = @_;
	return unless $str; return unless $key;
	print
	"\n<!--\nparent.decrypt_and_write('"; </td>
</tr>

<tr>
<td  class="h" >
<a name="59">59</a>
</td>

<td  class="c0" >

0

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

0

</td>

<td class="s"> 	print &encrypt($str,$key); </td>
</tr>

<tr>
<td  class="h" >
<a name="60">60</a>
</td>

<td  class="c0" >

0

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

0

</td>

<td class="s"> 	print "');\n// -->\n\n";
}
sub binary2ascii {
	return &str2ascii(&binary2str(@_));
}
sub ascii2binary {
	return &str2binary(&ascii2str($_[$[]));
}
sub str2binary {   my @str = split //, $_[$[];
	my @intarray = (); my $ii = $[;
	while (1) {
		last unless @str; $intarray[$ii]  = (0xFF & ord shift @str)<<24;
		last unless @str; $intarray[$ii] |= (0xFF & ord shift @str)<<16;
		last unless @str; $intarray[$ii] |= (0xFF & ord shift @str)<<8;
		last unless @str; $intarray[$ii] |=  0xFF & ord shift @str;
		$ii++;
	}
	return @intarray;
}
sub binary2str {
	my @str = ();
	foreach $i (@_) {
		push @str, chr (0xFF & ($i>>24)), chr (0xFF & ($i>>16)),
		 chr (0xFF & ($i>>8)), chr (0xFF & $i);
	}
	return join '', @str;
}
sub ascii2str {   my $a = $_[$[]; # converts pseudo-base64 to string of bytes
	# no warnings;
	local $^W = 0;
	$a =~ tr#-A-Za-z0-9+_##cd;
	my $ia = $[-1;  my $la = length $a;   # BUG not length, final!
	my $ib = $[;  my @b = ();
	my $carry;
	while (1) {   # reads 4 ascii chars and produces 3 bytes
		$ia++; last if ($ia>=$la);
		$b[$ib]  = $a2b{substr $a, $ia+$[, 1}<<2;
		$ia++; last if ($ia>=$la);
		$carry=$a2b{substr $a, $ia+$[, 1};  $b[$ib] |= ($carry>>4); $ib++;
		# if low 4 bits of $carry are 0 and its the last char, then break
		$carry = 0xF & $carry; last if ($carry == 0 && $ia == ($la-1));
		$b[$ib]  = $carry<<4;
		$ia++; last if ($ia>=$la);
		$carry=$a2b{substr $a, $ia+$[, 1};  $b[$ib] |= ($carry>>2); $ib++;
		# if low 2 bits of $carry are 0 and its the last char, then break
		$carry = 03 & $carry; last if ($carry == 0 && $ia == ($la-1));
		$b[$ib]  = $carry<<6;
		$ia++; last if ($ia>=$la);
		$b[$ib] |= $a2b{substr $a, $ia+$[, 1}; $ib++;
	}
	return pack 'C*', @b;
}
sub str2ascii {   my $b = $_[$[]; # converts string of bytes to pseudo-base64
	my $ib = $[;  my $lb = length $b;  my @s = ();
	my $b1; my $b2; my $b3;
	my $carry;
	while (1) {   # reads 3 bytes and produces 4 ascii chars
		if ($ib >= $lb) { last; };
		$b1 = ord substr $b, $ib+$[, 1;  $ib++;
		push @s, $b2a{$b1>>2}; $carry = 03 & $b1;
		if ($ib >= $lb) { push @s, $b2a{$carry<<4}; last; }
		$b2 = ord substr $b, $ib+$[, 1;  $ib++;
		push @s, $b2a{($b2>>4) | ($carry<<4)}; $carry = 0xF & $b2;
		if ($ib >= $lb) { push @s, $b2a{$carry<<2}; last; }
		$b3 = ord substr $b, $ib+$[, 1;  $ib++;
		push @s, $b2a{($b3>>6) | ($carry<<2)}, $b2a{077 & $b3};
		if (!$ENV{REMOTE_ADDR} && (($ib % 36) == 0)) { push @s, "\n"; }
	}
	return join ('', @s);
}
sub asciidigest {   # returns 22-char ascii signature
	return &binary2ascii(&binarydigest($_[$[]));
}
sub binarydigest { my $str = $_[$[];  # returns 4 32-bit-int binary signature
	# warning: mode of use invented by Peter Billam 1998, needs checking !
	return '' unless $str;
	# add 1 char ('0'..'15') at front to specify no of pad chars at end ...
	my $npads = 15 - ((length $str) % 16);
	$str  = chr($npads) . $str;
	if ($npads) { $str .= "\0" x $npads; }
	my @str = &str2binary($str);
	my @key = (0x61626364, 0x62636465, 0x63646566, 0x64656667);

	my ($cswap, $v0, $v1, $v2, $v3);
	my $c0 = 0x61626364; my $c1 = 0x62636465; # CBC Initial Value. Retain !
	my $c2 = 0x61626364; my $c3 = 0x62636465; # likewise (abcdbcde).
	while (@str) {
		# shift 2 blocks off front of str ...
		$v0 = shift @str; $v1 = shift @str; $v2 = shift @str; $v3 = shift @str;
		# cipher them XOR'd with previous stage ...
		($c0,$c1) = &tea_code ($v0^$c0, $v1^$c1, @key);
		($c2,$c3) = &tea_code ($v2^$c2, $v3^$c3, @key);
		# mix up the two cipher blocks with a 4-byte left rotation ...
		$cswap  = $c0; $c0=$c1; $c1=$c2; $c2=$c3; $c3=$cswap;
	}
	return ($c0,$c1,$c2,$c3);
}
sub encrypt { my ($str,$key)=@_; # encodes with CBC (Cypher Block Chaining)
	use integer;
	return '' unless $str; return '' unless $key;
	@key = &binarydigest($key);

	# add 1 char ('0'..'7') at front to specify no of pad chars at end ...
	my $npads = 7 - ((length $str) % 8);
	$str  = chr($npads|(0xF8 & &rand_byte)) . $str;
	if ($npads) {
		my $padding = pack 'CCCCCCC', &rand_byte, &rand_byte,
		 &rand_byte, &rand_byte, &rand_byte, &rand_byte, &rand_byte;
		$str  = $str . substr($padding,$[,$npads);
	}
	my @pblocks = &str2binary($str);
	my $v0; my $v1;
	my $c0 = 0x61626364; my $c1 = 0x62636465; # CBC Initial Value. Retain !
	my @cblocks;
	while (1) {
		last unless @pblocks; $v0 = shift @pblocks; $v1 = shift @pblocks;
		($c0,$c1) = &tea_code ($v0^$c0, $v1^$c1, @key);
		push @cblocks, $c0, $c1;
	}
	my $btmp = &binary2str(@cblocks);
	return &str2ascii( &binary2str(@cblocks) );
}
sub decrypt { my ($acstr, $key) = @_;   # decodes with CBC
	use integer;
	return '' unless $acstr; return '' unless $key;
	@key = &binarydigest($key);
	my $v0; my $v1; my $c0; my $c1; my @pblocks = (); my $de0; my $de1;
	my $lastc0 = 0x61626364; my $lastc1 = 0x62636465; # CBC Init Val. Retain!
	my @cblocks = &str2binary( &ascii2str($acstr) );
	while (1) {
		last unless @cblocks; $c0 = shift @cblocks; $c1 = shift @cblocks;
		($de0, $de1) = &tea_decode ($c0,$c1, @key);
		$v0 = $lastc0 ^ $de0;   $v1 = $lastc1 ^ $de1;
		push @pblocks, $v0, $v1;
		$lastc0 = $c0;   $lastc1 = $c1;
	}
	my $str = &binary2str( @pblocks );
	# remove no of pad chars at end specified by 1 char ('0'..'7') at front
	my $npads = 0x7 & ord $str; substr ($str, $[, 1) = '';
	if ($npads) { substr ($str, 0 - $npads) = ''; }
	return $str;
}
sub triple_encrypt { my ($plaintext,  $long_key) = @_;  # not yet ...
}
sub triple_decrypt { my ($cyphertext, $long_key) = @_;  # not yet ...
}
sub tea_code  { my ($v0,$v1, $k0,$k1,$k2,$k3) = @_;
	# TEA. 64-bit cleartext block in $v0,$v1. 128-bit key in $k0..$k3.
	# &prn("tea_code: v0=$v0 v1=$v1");
	use integer;
	my $sum = 0; my $n = 32;
	while ($n-- > 0) {
		$sum += 0x9e3779b9;   # TEA magic number delta
		$v0 += (($v1<<4)+$k0) ^ ($v1+$sum) ^ ((0x07FFFFFF & ($v1>>5))+$k1) ;
		$v0 &= 0xFFFFFFFF;
		$v1 += (($v0<<4)+$k2) ^ ($v0+$sum) ^ ((0x07FFFFFF & ($v0>>5))+$k3) ;
		$v1 &= 0xFFFFFFFF;
	}
	return ($v0, $v1);
}
sub tea_decode  { my ($v0,$v1, $k0,$k1,$k2,$k3) = @_;
	# TEA. 64-bit cyphertext block in $v0,$v1. 128-bit key in $k0..$k3.
	use integer;
	my $sum = 0; my $n = 32;
	$sum = 0x9e3779b9 << 5 ;   # TEA magic number delta
	while ($n-- > 0) {
		$v1 -= (($v0<<4)+$k2) ^ ($v0+$sum) ^ ((0x07FFFFFF & ($v0>>5))+$k3) ;
		$v1 &= 0xFFFFFFFF;
		$v0 -= (($v1<<4)+$k0) ^ ($v1+$sum) ^ ((0x07FFFFFF & ($v1>>5))+$k1) ;
		$v0 &= 0xFFFFFFFF;
		$sum -= 0x9e3779b9 ;
	}
	return ($v0, $v1);
}
sub rand_byte {
	if (! $rand_byte_already_called) {
		srand(time() ^ ($$+($$<<15))); # could do better, but its only padding
		$rand_byte_already_called = 1;
	}
	int(rand 256);
}
1;

__DATA__