=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;
[download]