package StoryServer::Crypt;
use strict;
BEGIN { require 5.005; }

use vars '$VERSION';
$VERSION = 1.0;

use Carp qw/croak confess/;

use Exporter;
use base 'Exporter';
use vars qw'@EXPORT_OK';
@EXPORT_OK = qw/is_crypted encrypt decrypt decrypt_/;

my $salt_ = ':.oO0zZ1l,';
my $code_ = 'wqceryHtuopadsfghIjlkzxvbn1m2345,WQERTYUiOPSADFGJKLZXCBVNM68790.';

my @salt_ = split//,$salt_;
my @code_ = split//,$code_;

my (%salt_, %code_);
for (my $n=0; $n<@salt_; ++$n) { $salt_{$salt_[$n]} = $n }
for (my $n=0; $n<@code_; ++$n) { $code_{$code_[$n]} = $n }

sub is_crypted {
	my ($s) = @_;
	return (
		$s=~/\A2[$salt_]{2}[$code_]+\z/
	);
}

sub encrypt {
	my ($plaintext, $salt) = @_;
	if (!defined $salt) {
		$salt = ($salt_[rand @salt_]).($salt_[rand @salt_]);
	}
	_delta (_decodesalt ($salt));
	return '2'.$salt._encodelen(length($plaintext))._encodetext($plaintext);
}

sub decrypt {
	my ($ciphertext) = @_;
	my ($salt, $cryptolength, $cryptostring);
	if (length $ciphertext <= 88) {
		($salt, $cryptolength, $cryptostring) = ($ciphertext =~ m/^2(..)(.)(.+)/);
	} else {
		($salt, $cryptolength, $cryptostring) = ($ciphertext =~ m/^2(..)(.{6})(.+)/);
	}

	_delta (_decodesalt($salt));

	return substr (_decodetext($cryptostring), 0, _decodelen ($cryptolength));
}

sub decrypt_ { my ($x)=@_; return (is_crypted($x) ? decrypt($x) : $x) }

sub _decodelen {
	my ($x) = @_;
	if (length $x == 1) {
		return $code_{$x};
	} elsif (length $x == 6) {
		return _decode64 (scalar reverse substr ($x, 1, 4));
	} else {
		croak ("_encodelen: Unrecognised format for length");
	}
}

sub _encodelen {
	my ($len) = @_;
	if ($len<64) {
		return $code_[$len];
	} else {
		return "w".(scalar reverse _unjoin64 ($len))."w";
	}
}

sub _decodesalt {
	my ($salt) = @_;
	my ($a, $b) = ($salt =~ /\A([$salt_])([$salt_])\z/);
	confess "_decodesalt: Invalid salt $salt" if !defined $a;
	return 10*$salt_{$b} + $salt_{$a};
}

sub _decodetext {
	my ($x) = @_;
	if (length($x) % 4) { confess "_decodetext: length is not a multiple of 4"; }
	my $r = '';
	while (length (my $chunk = substr ($x, 0, 4, ''))) {
		$r .= _shuffle_decode (_decode64 ($chunk));
	}
	return $r;
}

sub _encodetext {
	my ($c) = @_;
	$c .= '?'x(3-(length($c)%3));
	confess("failed sanity check") if $c%3;
	my $r = '';
        while (length (my $chunk = substr ($c, 0, 3, ''))) {
                $r .= _encode64 (_shuffle_encode ($chunk));
        }
        return $r;
}

sub _decode64 {
	my ($c) = @_;
	if (length $c != 4) {
		confess "_decode64: '$c' is not 4 bytes long";
	}
	my $r = 0;
	for (my $n = 0; $n<4; ++$n) {
		$r += ( $code_{substr($c, 3-$n, 1)}<<(6*$n) );
	}
	return $r;
}

sub _encode64 {
	my ($n) = @_;
	if ($n >= 2**24) { confess ("_encode64: $n > 24 bits"); }
	return ( $code_[($n>>18)&63] . $code_[($n>>12)&63] . $code_[($n>>6)&63] . $code_[$n&63] );
}

{
my $delta;

sub _delta ($) { ($delta) = @_; }

sub _shuffle_decode {
	my ($n) = @_;
	confess "_bitshuffle: $delta is not initialised" unless defined $delta;
	my $a = (($n>>18)&0x3F) + (($n>> 6)&0xC0);
	my $b = (($n>> 2)&0xF0) + (($n>>14)&15);
	my $c = (($n<< 2)&0xFC) + (($n>>10)&3);

	my $rv = sprintf "%c%c%c", ($a-$delta)%256, ($b-$a)%256, ($c-$b)%256;
	$delta = $c;
	return $rv;
}

sub _shuffle_encode {
	my ($pqr) = @_;
	my ($p, $q, $r) = unpack ('c3', $pqr);
	my ($a, $b, $c) = (($p+$delta)%256, ($p+$q+$delta)%256, ($p+$q+$r+$delta)%256);
	$delta = $c;
	my $x = (($a<<2)&0xFC) + (($b>>2)&0x03);
	my $y = (($b<<6)&0xC0) + (($a>>2)&0x30) + (($c<<2)&0x0C) + ($b>>6);
	my $z = (($b<<2)&0xC0) + ($c>>2);
	return ( ($x<<16) + ($y<<8) + $z );
}
}


1;	# be true