package UAcoder;

use strict;
use vars qw($VERSION @ISA @EXPORT $LINE $FUNC $Q $A);
use CGI;
$Q=new CGI(); $A=new CGI(); my $q=new CGI;
$Q->delete_all(); $A->delete_all();
use autouse 'Digest::MD5' => qw(md5_hex);
use autouse 'Digest::SHA1' => qw(sha1_hex);

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&genPASS $Q $A);
$VERSION = '1.01';

##########################

sub new {
	my $class = shift;

	$FUNC = defined $_[0] ? $_[0] : '';
	if( $FUNC=~/SHA1/i ){ $FUNC = sub{ sha1_hex(@_) } }
	else { $FUNC = sub{ md5_hex(@_) } }

	my $self = [];
	bless $self, $class;
}

sub field {
	my $self = shift;
	my $i = @$self>0 ? @$self : 1;
	$self->[$i] = $_[0] if @_;
	$self;
}

sub pass {
	my $self = shift;
	$self->[0] = $_[0];
}

sub line {
	my $self = shift;
	$self->[1] = $_[0];
}

##########################

sub coding {
	my $self = shift;
	my( $pass,@field ) = @{$self};
	my( @fN,$p )=();
	die 'Password Error!' if !defined $pass || length $pass<32;

	unless( @field ){
		for $p ( $Q->param ){ push( @field, map{"$p=$_"} $Q->param($p) ) }
	}
	$Q->delete_all(); my $fN = @field;

	for( 0..$#field ){ $fN[$_] = length $field[$_] }
	$LINE = join('a', $fN,@fN).'a'.unpack('H*', join('', @field));

	my $kADD = &genKEY;
	sumKey( substr( $pass, 0,16 ), $kADD );
	Combi( substr( $pass, 0,16 ) );
	addKey( substr( $pass, 0,16 ), substr( $kADD, 0,15 ) );

	$kADD = &genKEY;
	sumKey( substr( $pass, 16,16 ), $kADD );
	Combi( substr( $pass, 16,16 ) );
	addKey( substr( $pass, 16,16 ), substr( $kADD, 0,15 ) );

	$LINE;
}


sub decoding {

	my $self = shift;
	$LINE = $self->[1];
	my $pQ = defined $q->param('Q') ? $q->param('Q') : '';
	my $pk = defined $q->param('keywords') ? $q->param('keywords') : '';

	if( !$LINE && $pQ ){
		$LINE = $pQ;
		$q->delete('Q')
	} 
	elsif( !$LINE && $pk ){
		$LINE = $pk;
		$q->delete('keywords');
	}
	die 'No string for decoding!' if !defined $LINE || length $LINE<32;

	my( $pass,$fN,@fN,@field )=( $self->[0],0 );
	die 'Password Error!' if !defined $pass || length $pass<32;

	my $kADD = unaddKey( substr( $pass, 16,16 ) );
	unCombi( substr( $pass, 16,16 ) );
	unsumKey( substr( $pass, 16,16 ), $kADD );

	$kADD = unaddKey( substr( $pass, 0,16 ) );
	unCombi( substr( $pass, 0,16 ) );
	unsumKey( substr( $pass, 0,16 ), $kADD );

	$LINE =~ s/^(\d+)a//;
	for( 0..$1-1 ){ $LINE=~s/^(\d+)a//; $fN[$_]=$1 }
	$LINE = pack('H*', $LINE);
	for( 0..$#fN ){
		$field[$_] = substr( $LINE, $fN,$fN[$_] );
		$fN += $fN[$_];
	}

	$A->delete_all();
	for( @field ){
		0=~/(.)/; s/^([^=]+)\=//;
		my $n= defined $1 ? $1 : 'keywords';
		my $v= defined $_ ? $_ : '';
		$A->append(-name=>$n, -values=>$v);
	}

	\@field;
}

##########################

sub Combi {

	my( $key )=@_;
	my( $i,$len )=( 0,length $LINE );

	my $str = "-" x ($len+15);
	for( 0..$len-1 ) {
		my $n = hex substr( $key, $_-$i,1 );
		substr( $str, $_+$n,1 ) = substr( $LINE, $_,1 );
		$i=$_+1 if $_-$i+1>=16;
	}
	
	$LINE = $str;
}

sub unCombi {

	my( $key )=@_;
	my( $i,$len )=( 0,length $LINE );

	my $str = "\x00" x ($len-15);
	for( 0..$len-16 ) {
		my $n = hex substr( $key, $_-$i,1 );
		substr( $str, $_,1 ) = substr( $LINE, $_+$n,1 );
		$i=$_+1 if $_-$i+1>=16;
	}
	
	$LINE = $str;
}


sub addKey {

	my( $pas, $key )=@_; my $i=0;

	for( @{holeSearch( $pas, length($LINE)-15 )} ){
		substr( $LINE, $_,1 ) = substr( $key, $i,1 );
		$i++;
	}
}

sub unaddKey {

	my( $pas )=@_;
	my( $i, $key )=( 0, "\x00" x 15 );

	for( @{holeSearch( $pas, length($LINE)-15 )} ){
		substr( $key, $i,1 ) = substr( $LINE, $_,1 );
		$i++;
	}

	return $key;
}


sub sumKey {

	my( $pas, $kADD )=@_;
	my $kSUM = &{$FUNC}( $pas,$kADD,0 );
	my( $i,$j,$sum,$len )=( 0,0,0,length $kSUM );

	for( 0..length($LINE)-1 ) {

		substr($LINE, $_,1)=Plus( substr($LINE, $_,1), substr($kSUM, $_-$i,1) );

		if( $_-$i+1==$len ){
			$i=$_+1; $j++;
			$kSUM = &{$FUNC}( $pas,$kADD,$j );
		}
	}
}

sub unsumKey {

	my( $pas, $kADD )=@_;
	my $kSUM = &{$FUNC}( $pas,$kADD,0 );
	my( $i,$j,$sum,$len )=( 0,0,0,length $kSUM );

	for( 0..length($LINE)-1 ) {

		substr($LINE, $_,1)=Minus( substr($LINE, $_,1), substr($kSUM, $_-$i,1) );

		if( $_-$i+1==$len ){
			$i=$_+1; $j++;
			$kSUM = &{$FUNC}( $pas,$kADD,$j );
		}
	}
}

##########################

sub genPASS {

	my( $i,$r,$pas,@pas )=();

	for $i ( 0..15 ){
		do{ $r = int rand(16) } until( $pas[$i+$r]!=1 );
		$pas[$i+$r]=1;
		$pas[$i+$r+16]=1;
		$pas = $pas.sprintf('%x', $r);
	}

	@pas=();
	for $i ( 0..15 ){
		do{ $r = int rand(16) } until( $pas[$i+$r]!=1 );
		$pas[$i+$r]=1;
		$pas[$i+$r+16]=1;
		$pas = $pas.sprintf('%x', $r);
	}
	$pas;
}


sub genKEY {

	my( $KEY )=();
	for( 0..14 ){ $KEY = $KEY.sprintf('%x', int rand 16) }
	$KEY;
}

##########################

sub Plus {

	my( $A,$B )=( hex $_[0],hex $_[1] );
	substr( sprintf('%x', $A+$B), -1,1 );
}


sub Minus{

	my( $A,$B,$sum )=( hex $_[0],hex $_[1] );
	$sum = $A>=$B	?	$A-$B	:	16-$B+$A;
	sprintf('%x', $sum);
}


sub holeSearch {	#holes search

	my( $pas,$len )=@_;
	my( @hole,%open,%close )=();

	my $min = ( $len<31 ? 16 : $len-16 );
	my $max = ( $len<16 ? $len-1 : 15 );

	for( 0..$max, $min..$len-1 ){

		my $i = sprintf('%.0f', ($_/16 - (int($_/16)))*16); 
		my $n = hex(substr( $pas, $i,1 )) + $_;
		$close{$n} = 1;
	}
	for ( 0..15, $len..$len+14 ){ $open{$_}=1 unless $close{$_} }
	for( sort {$a<=>$b} keys %open ){ push( @hole,$_ ) }

	return \@hole;
}

1;


=head1 NAME

UAcoder - Coding and decoding of the information for transfer and reception under the protocol HTTP

=head1 SYNOPSIS

## Password generation
use UAcoder;
my $pass = genPASS; #Password for coding and decoding of the information

## Coding
my $line = 'Test line for check:)';	#The information for coding and transfer on HTTP

use UAcoder;
my $ctx = new UAcoder();
$ctx->field($line);
$ctx->pass($pass); # $pass - Password
my $L = $ctx->coding; 	#Code for transfer on HTTP

## Decoding
use UAcoder;
my $ctx = new UAcoder();
$ctx->line($L); # $L - Code for transfer on HTTP
$ctx->pass($pass); # $pass - Password
my $D = $ctx->decoding;
my $field = $D->[0];

=head1 DESCRIPTION

The module codes and decodes given for transfer under the protocol HTTP.
With the help of the Module UAcoder it is possible to transfer and to accept the symbolical data of the protocol ANSI.

A Simple Example. It is necessary to code and to transfer a line:
$line = 'Test line for check:)';

Task of a Password and Coding of the data.
$pass = genPASS;

We connect the module:
use UAcoder;
my $ctx = new UAcoder();
$ctx->field($line);
$ctx->pass($pass);

We code the data:
my $L = $ctx->coding;

We receive a line of such kind:
d571a8e236c4f9b06663925767e0c4542626370666820f65106b923316f95a65 ($L)

We transfer a line on HTTP.
We receive a line:
use UAcoder;
my $ctx = new UAcoder();
$ctx->line($L); # $L - Code for transfer on HTTP
$ctx->pass($pass);
my $D = $ctx->decoding;
my $field = $D->[0];

The lines should be equal: $field eq $line

=head1 AUTHOR

Gorhilin V. V. 
http://gorchilin.com/articles/UAcoder/uacoder
2004

=cut