File Coverage

blib/lib/Crypt/Tea_JS.pm

Criterion	Covered	Total	%
statement	236	254	92.9
branch	43	64	67.1
condition	11	15	73.3
subroutine	25	28	89.2
pod	6	19	31.5
total	321	380	84.4

# Tea_JS.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_JS;
#    $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_JS;
$VERSION = '2.23';
# Don't like depending on externals; this is strong encrytion ... but ...
require Exporter;
@ISA = qw(Exporter);

eval { require XSLoader; XSLoader::load('Crypt::Tea_JS', $VERSION); };
if ($@) {   # 2.23 revert to PurePerl
	*tea_code      = \&pp_tea_code;
	*tea_decode    = \&pp_tea_decode;
	*oldtea_code   = \&pp_oldtea_code;
	*oldtea_decode = \&pp_oldtea_decode;
}

@EXPORT = qw(asciidigest encrypt decrypt tea_in_javascript);
@EXPORT_OK = qw(str2ascii ascii2str encrypt_and_write);
%EXPORT_TAGS = (ALL => [@EXPORT,@EXPORT_OK]);

BEGIN {
	if ($] < 5.006) {
		$INC{"bytes.pm"} = 1;       # cheating that bytes.pm is loaded
		*bytes::import   = sub { }; # do nothing
		*bytes::unimport = sub { };
	}
	if ($] > 5.007) { require Encode; }
}
if (! defined &tea_code) {
	die "C library missing, and couldn't eval pp_tea_code\n";
}
use bytes;

# 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="81">81</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="82">82</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
	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;   # 2.16
}
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;
	if ($] > 5.007 && Encode::is_utf8($str)) {
		Encode::_utf8_off($str);
		# $str = Encode::encode_utf8($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 (Cipher Block Chaining)
	return '' unless $str; return '' unless $key;
	if ($] > 5.007 && Encode::is_utf8($str)) {
		Encode::_utf8_off($str);
		# $str = Encode::encode_utf8($str);
	}
	use integer;
	@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;
	}
	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 ...
}

# PurePerl versions: introduced in 2.23
sub pp_tea_code  { my ($v0,$v1,@k) = @_;
	# Note that both "<<" and ">>" in Perl are implemented directly using
	# "<<" and ">>" in C.  If "use integer" (see "Integer Arithmetic") is in
	# force then signed C integers are used, else unsigned C integers are used.
	use integer;
	my $sum = 0; my $n = 32;
	while ($n-- > 0) {
		$v0 += ((($v1<<4)^(0x07FFFFFF&($v1>>5)))+$v1) ^ ($sum+$k[$sum&3]);
		$v0 &= 0xFFFFFFFF;
		$sum += 0x9e3779b9;   # TEA magic number delta
		# $sum &= 0xFFFFFFFF; # changes nothing
		$v1 += ((($v0<<4)^(0x07FFFFFF&($v0>>5)))+$v0)^($sum+$k[($sum>>11)&3]);
		$v1 &= 0xFFFFFFFF;
	}
	return ($v0, $v1);
}
sub pp_tea_decode  { my ($v0,$v1, @k) = @_;
	use integer;
	my $sum = 0; my $n = 32;
	$sum = 0x9e3779b9 << 5 ;   # TEA magic number delta
	while ($n-- > 0) {
		$v1 -= ((($v0<<4)^(0x07FFFFFF&($v0>>5)))+$v0)^($sum+$k[($sum>>11)&3]);
		$v1 &= 0xFFFFFFFF;
		$sum -= 0x9e3779b9 ;
		$v0 -= ((($v1<<4)^(0x07FFFFFF&($v1>>5)))+$v1) ^ ($sum+$k[$sum&3]);
		$v0 &= 0xFFFFFFFF;
	}
	return ($v0, $v1);
}
sub pp_oldtea_code  { my ($v0,$v1, $k0,$k1,$k2,$k3) = @_;
	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 pp_oldtea_decode  { my ($v0,$v1, $k0,$k1,$k2,$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__