=head1 AUTHOR

Jeroen Elassaiss-Schaap

=head1 LICENSE

Perl/ artisitic license

=head1 STATUS

Alpha

=cut
  
use Exporter;
use vars qw( @EXPORT @ISA @VERSION %bits_char);
@VERSION = 0.03;
@ISA = qw( Exporter );
@EXPORT = qw( &encode &decode &encode_tr &decode_tr);

%bits_char = ( a => 6, A => 8, '' => undef, u =>5, l => 5);

sub encode{
	my $hash = shift;
	my @data = @{$hash->{'data'}};
	my @bitsizes = @{$hash->{'bitsizes'}};
	my ($str, $bitstr);
	for my $bits (@bitsizes) {
		$bitstr .= unpack("b$bits", pack('VV', shift( @data ) ));
	}
	$bitstr .= '0' x ( length($bitstr) % 6 );
 	for my $item (0..( length($bitstr) / 6 - 1 )){
	 	my $val=pack('b6', substr($bitstr, $item*6, 6) );
	 	for ($val) {
	     	tr	[\100\077\000-\010\011-\043\044-\075]
	     		[\045\055\060-\071\101-\132\141-\172];
			$str.=$_;
		}
 	}
	$str;
}

sub decode{
	my $hash = shift;
	my $str = $hash->{'str'};
	my @bitsizes= @{$hash->{'bitsizes'}};
 	my $bitstr = _bits( $str );
 	my $val;
 	my @data;
	my $pointer = 0;
	for my $bits (@bitsizes) {
		my $val;
		for ($bits) {
			$val = unpack('c',pack("b$_",substr( $bitstr, $pointer, $_ ))), last
				if $bits < 9;
			$val = unpack('v',pack("b$_",substr( $bitstr, $pointer, $_ ))), last
				if $bits < 17;
			$val = unpack('V',pack("b32",substr( $bitstr, $pointer, $_ ))), last
				if $bits < 33;
			if (! eval('{$val = unpack("Q",pack("b$_",substr( '.
					'$bitstr, $pointer, $_ )));1;}') ) {
				warn "only converted 32 bits instead of $_\n";
				$val = unpack('V',pack("b$_",
					substr( $bitstr, $pointer, $_ )));
			}
		}
		push( @data, $val);
	    $pointer += $bits;
	}
	@data;
}

sub _bits{
	my $str = shift;
	my $bitstr;
	for (split //, $str){
		tr	[\045\055\060-\071\101-\132\141-\172]
			[\100\077\000-\010\011-\043\044-\075];
		$bitstr .= unpack("b6",$_); 
	}
	$bitstr;
}

sub encode_tr{
	my @array = _hash2array( shift);
	my @tr = map{ 
		my $type = $_->[2];
		last unless _check( $type );
		_tr( $_, $type ); 
	} @array;
	@tr = _trlatedjoin( @tr );
	encode( { data => $tr[0], bitsizes => $tr[1] } );
}


sub _tr{
	my $array = shift;
	my $type = shift;
	my $bc = $bits_char{ $type } or return ( [$array->[0]], [$array->[1]] );
	my @bitsizes = _bitsizes( $array, $type );
	my @input = split //, $array->[0];
	my @data = map{ 
		my $input = shift( @input );
		$input = _trchar( $type, $input);		
		unpack( 'c', $input );
	} @bitsizes;
	( \@data, \@bitsizes );
}

sub _trchar{
	my $type = shift;
	my $char = shift;
	for ( $char ) {
		$char =~ tr	[\060-\071\101-\132\141-\172]
					[\000-\010\011-\043\044-\075],
			last if ( $type eq 'a');
		$char =~ tr	[\141-\172]
					[\000-\031],
			last if ( $type eq 'l');
		$char =~ tr	[\101-\132]
					[\000-\031],
			last if ( $type eq 'u');
	}	
	$char;
}

sub _trlatedjoin{
	my @tr0;
	my @tr1;
	my $ref;
	while( $ref = shift) {
		push( @tr0, @$ref );
		push( @tr1, @{ shift(@_) } );
	}
	( \@tr0, \@tr1 );
}

sub decode_tr{
	my $hash = shift;
	my @array = _hash2array( $hash );
	my @bitsizes = map{ 
		my $type = $_->[2];
		last unless _check( $type ); 
		_bitsizes( $_, $type ); 
	} @array;
	my @items = decode( { str => $hash->{str}, bitsizes => \@bitsizes } );
	map{ 
		my $type = $_->[2];
		last unless _check( $type ); 
		_dejoin( $_, $type, \@items ); 
	} @array;
}

sub _dejoin{
	my $array = shift;
	my $type = shift;
	my $itemref = shift;
	my $bc = $type? $bits_char{ $type } : $array->[1];
	my $number = int( $array->[1] / $bc );
	$number += (( $array->[1] / $bc ) - $number ) > 0;
	my @untr = splice( @$itemref, 0, $number );
	join '', map{
		_detr( $type, pack( 'c', $_ ));	
	} @untr;
}

sub _detr{
	my $type = shift;
	my $char = shift;;
	for ( $char ) {
		$char =~ tr	[\000-\010\011-\043\044-\075]
					[\060-\071\101-\132\141-\172],
			last if( $type eq 'a' );
		$char =~ tr	[\000-\031]
					[\141-\172],
			last if ( $type eq 'l');
		$char =~ tr	[\000-\031]
					[\101-\132],
			last if ( $type eq 'u');
		last if( $type eq 'A' );
		$char = unpack( 'c', $char);
	}	
	$char;
}

sub _hash2array{
	my $hash = shift;
	_calc_bitsizes( $hash ) unless defined($hash->{bitsizes});
	map { [ shift( @{ $hash->{data} }), $_, shift( @{ $hash->{types} }) ];
		} @{ $hash->{bitsizes} } ;
}

sub _calc_bitsizes{
	my $hash = shift;
	@{ $hash->{bitsizes} } = map{ 
		my $bc =  $bits_char{ $_ };
		my $length = shift( @{ $hash->{lengths} });
		defined( $bc )?	 $length * $bc : $length;
	}@{ $hash->{types} };
}

sub _bitsizes{
	my $array = shift;
	my $type = shift;
	my $bc = $bits_char{ $type } or return $array->[1];
	my @bitsizes;
	my $n = int( $array->[1] / $bc );
	if( $n ){
		for ( 1..$n ) {
			push( @bitsizes, $bc);
		}
	}
	my $rem;
	push( @bitsizes, $rem ) if ( $rem = $array->[1] % $bc) ;
	@bitsizes;
}

sub _check{
	my $type = shift;
	return 1 unless( defined $type );
	my $found;
	for ( 'A','a','','l','u') {
		$found +=  $type eq $_;
	}
	$found;
}

1;