File Coverage

blib/lib/Data/BISON/Encoder.pm

Criterion	Covered	Total	%
statement	33	102	32.3
branch	0	32	0.0
condition	0	15	0.0
subroutine	11	20	55.0
pod	1	1	100.0
total	45	170	26.4

package Data::BISON::Encoder;

use warnings;
use strict;
use Carp;
use Data::BISON::Constants;
use Data::BISON::yEnc qw(encode_yEnc);
use Scalar::Util qw(blessed);
use Scalar::Util::Numeric qw(isnum isint isfloat);
use Encode qw();
use Config;

use version; our $VERSION = qv( '0.0.3' );

our @ISA = qw(Data::BISON::Base);
use Data::BISON::Base {
    yenc    => { default => 0 },
    double  => { default => 0 },
    version => {
        default => MIN_VER,
        set     => sub {
            my ( $self, $attr, $ver ) = @_;
            if ( $ver < MIN_VER || $ver > CUR_VER ) {
                my $desc = ( MIN_VER == CUR_VER )
                  ? MIN_VER
                  : 'between ' . MIN_VER . ' and ' . CUR_VER;
                croak "Version must be $desc";
            }
            $self->{$attr} = $ver;
        },
    },
    sort => { default => 0 },
};

my @INT_LEN = ( NULL, INT8, INT16, INT24, INT32 );

sub _encode_size {
    my $self = shift;
    my $size = shift;

    if ( $size > 0xFFFF ) {
        croak "Maximum array / hash size is 65535";
    }

    return pack( 'v', $size );
}

sub _encode_string {
    my $self = shift;
    my $str  = shift;

    my $octets = Encode::encode( UTF8, $str );
    $octets =~ s{(\\|\0)}{\\$1}g;

    return $octets . "\0";
}

sub _encode_hash {
    my $self = shift;
    my $hash = shift;

    my @enc = ();

    my @keys = keys %$hash;
    @keys = sort @keys if $self->sort;

    push @enc, $self->_encode_size( scalar @keys );

    for my $key ( @keys ) {
        push @enc, $self->_encode_string( $key );
        push @enc, $self->_encode_obj( $hash->{$key} );
    }

    return join( '', @enc );
}

sub _encode_array {
    my $self  = shift;
    my $array = shift;

    my @enc = ();
    push @enc, $self->_encode_size( scalar @$array );
    push @enc, map { $self->_encode_obj( $_ ) } @$array;

    return join( '', @enc );
}

# Unlike the above these return a serialized value /with/ the type byte
# prepended.

sub _encode_int {
    my $self = shift;
    my $int  = shift;

    my @rep = map { ord } split( //, pack( 'V', $int ) );

    # Trim extra bytes
    if ( $int < 0 ) {
        push @rep, 0xFF;
        pop @rep while @rep > 1 && $rep[-1] == 0xFF && $rep[-2] >= 0x80;
    }
    else {
        push @rep, 0x00;
        pop @rep while @rep > 1 && $rep[-1] == 0x00 && $rep[-2] < 0x80;
    }

    return chr( $INT_LEN[@rep] ) . pack( 'C*', @rep );
}

sub _encode_float {
    my $self  = shift;
    my $float = shift;

    my $rep = pack( $self->double ? 'd' : 'f', $float );

    if ( $Config{byteorder} eq '4321' ) {
        $rep = join( '', reverse split( //, $rep ) );
    }

    return chr( $self->double ? DOUBLE: FLOAT ) . $rep;
}

sub _encode_obj {
    my $self = shift;
    my $obj  = shift;

    if ( !defined $obj ) {
        return chr( UNDEF );
    }
    elsif ( my $type = ref $obj ) {
        if ( $type eq 'HASH' ) {
            return chr( HASH ) . $self->_encode_hash( $obj );
        }
        elsif ( $type eq 'ARRAY' ) {
            return chr( ARRAY ) . $self->_encode_array( $obj );
        }
        elsif ( blessed $obj ) {
            croak "Can't serialize objects yet";
        }
    }
    elsif ( isnum $obj) {
        if ( isint $obj ) {
            return $self->_encode_int( $obj );
        }
        else {
            return $self->_encode_float( $obj );
        }
    }
    else {
        return chr( STRING ) . $self->_encode_string( $obj );
    }
}

sub _encode {
    my $self = shift;

    return FMB . $self->_encode_obj( shift );
}

sub encode {
    my $self = shift;

    croak __PACKAGE__ . "->encode takes a single argument"
      unless @_ == 1;

    my $obj = shift;

    my $enc_data = $self->_encode( $obj );

    if ( $self->yenc ) {
        return encode_yEnc( $enc_data );
    }

    return $enc_data;
}

1;
__END__