Crypt-Tea_JS
view release on metacpan or search on metacpan
# 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 (<DATA>) { last if /^EOT$/; push @js, $_; } join '', @js;
}
sub encrypt_and_write { my ($str, $key) = @_;
return unless $str; return unless $key;
print
"<SCRIPT LANGUAGE=\"JavaScript\">\n<!--\nparent.decrypt_and_write('";
print encrypt($str,$key);
print "');\n// -->\n</SCRIPT>\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 ;
( run in 0.745 second using v1.01-cache-2.11-cpan-5735350b133 )