File Coverage

blib/lib/Data/ParseBinary.pm

Criterion	Covered	Total	%
statement	179	193	92.7
branch	29	30	96.6
condition	24	33	72.7
subroutine	89	103	86.4
pod	35	60	58.3
total	356	419	84.9

package Data::ParseBinary;
use strict;
use warnings;
no warnings 'once';

our $VERSION = 0.31;

use Data::ParseBinary::Core;
use Data::ParseBinary::Adapters;
use Data::ParseBinary::Streams;
use Data::ParseBinary::Stream::String;
use Data::ParseBinary::Stream::Wrapper;
use Data::ParseBinary::Stream::Bit;
use Data::ParseBinary::Stream::StringBuffer;
use Data::ParseBinary::Stream::File;
use Data::ParseBinary::Constructs;
use Config;

our $DefaultPass = Data::ParseBinary::NullConstruct->create();
$Data::ParseBinary::BaseConstruct::DefaultPass = $DefaultPass;
our $print_debug_info = undef;

my $support_64_bit_int;
eval { my $x = pack "Q", 5 };
if ( $@ ) {
    $support_64_bit_int = 0;
    require Math::BigInt;
} else {
	$support_64_bit_int = 1
}
$@ = '';

sub UBInt16 { return Data::ParseBinary::Primitive->create($_[0], 2, "n") }
sub UBInt32 { return Data::ParseBinary::Primitive->create($_[0], 4, "N") }
sub ULInt16 { return Data::ParseBinary::Primitive->create($_[0], 2, "v") }
sub ULInt32 { return Data::ParseBinary::Primitive->create($_[0], 4, "V") }
sub UNInt32 { return Data::ParseBinary::Primitive->create($_[0], 4, "L") }
sub UNInt16 { return Data::ParseBinary::Primitive->create($_[0], 2, "S") }
sub UNInt8  { return Data::ParseBinary::Primitive->create($_[0], 1, "C") }
sub SNInt32 { return Data::ParseBinary::Primitive->create($_[0], 4, "l") }
sub SNInt16 { return Data::ParseBinary::Primitive->create($_[0], 2, "s") }
sub SNInt8  { return Data::ParseBinary::Primitive->create($_[0], 1, "c") }
sub NFloat32{ return Data::ParseBinary::Primitive->create($_[0], 4, "f") }
sub NFloat64{ return Data::ParseBinary::Primitive->create($_[0], 8, "d") };
*SBInt8 = \&SNInt8;
*SLInt8 = \&SNInt8;
*Byte = \&UNInt8;
*UBInt8 = \&UNInt8;
*ULInt8 = \&UNInt8;

my $create_64_classes = sub {
    my ($name, $is_signed, $is_be) = @_;
    return Data::ParseBinary::ExtendedNumberAdapter->create(Field($name, 8), $is_signed, $is_be);
};

if ($support_64_bit_int) {
    *UNInt64 = sub { return Data::ParseBinary::Primitive->create($_[0], 8, "Q") };
    *SNInt64 = sub { return Data::ParseBinary::Primitive->create($_[0], 8, "q") };
}

if ($^V ge v5.10.0) {
    *SBInt16 = sub { return Data::ParseBinary::Primitive->create($_[0], 2, "s>") };
    *SLInt16 = sub { return Data::ParseBinary::Primitive->create($_[0], 2, "s<") };
    *SBInt32 = sub { return Data::ParseBinary::Primitive->create($_[0], 4, "l>") };
    *SLInt32 = sub { return Data::ParseBinary::Primitive->create($_[0], 4, "l<") };
    *BFloat32= sub { return Data::ParseBinary::Primitive->create($_[0], 4, "f>") };
    *LFloat32= sub { return Data::ParseBinary::Primitive->create($_[0], 4, "f<") };
    if ($support_64_bit_int) {
        *SBInt64 = sub { return Data::ParseBinary::Primitive->create($_[0], 8, "q>") };
        *SLInt64 = sub { return Data::ParseBinary::Primitive->create($_[0], 8, "q<") };
        *UBInt64 = sub { return Data::ParseBinary::Primitive->create($_[0], 8, "Q>") };
        *ULInt64 = sub { return Data::ParseBinary::Primitive->create($_[0], 8, "Q<") };
    } else {
        *SBInt64 = sub { $create_64_classes->($_[0], 1, 1) };
        *SLInt64 = sub { $create_64_classes->($_[0], 1, 0) };
        *UBInt64 = sub { $create_64_classes->($_[0], 0, 1) };
        *ULInt64 = sub { $create_64_classes->($_[0], 0, 0) };
    }
    *BFloat64= sub { return Data::ParseBinary::Primitive->create($_[0], 8, "d>") };
    *LFloat64= sub { return Data::ParseBinary::Primitive->create($_[0], 8, "d<") };
} else {
    my ($primitive_class, $reversed_class);
    if (pack('s', -31337) eq "\x85\x97") {
        $primitive_class = 'Data::ParseBinary::Primitive';
        $reversed_class  = 'Data::ParseBinary::ReveresedPrimitive';
    } else {
        $reversed_class  = 'Data::ParseBinary::Primitive';
        $primitive_class = 'Data::ParseBinary::ReveresedPrimitive';
    }
    *SBInt16 = sub { return $primitive_class->create($_[0], 2, "s") };
    *SLInt16 = sub { return $reversed_class->create($_[0], 2, "s") };
    *SBInt32 = sub { return $primitive_class->create($_[0], 4, "l") };
    *SLInt32 = sub { return $reversed_class->create($_[0], 4, "l") };
    *BFloat32= sub { return $primitive_class->create($_[0], 4, "f") };
    *LFloat32= sub { return $reversed_class->create($_[0], 4, "f") };
    if ($support_64_bit_int) {
        *SBInt64 = sub { return $primitive_class->create($_[0], 8, "q") };
        *SLInt64 = sub { return $reversed_class->create($_[0], 8, "q") };
        *UBInt64 = sub { return $primitive_class->create($_[0], 8, "Q") };
        *ULInt64 = sub { return $reversed_class->create($_[0], 8, "Q") };
    } else {
        *SBInt64 = sub { $create_64_classes->($_[0], 1, 1) };
        *SLInt64 = sub { $create_64_classes->($_[0], 1, 0) };
        *UBInt64 = sub { $create_64_classes->($_[0], 0, 1) };
        *ULInt64 = sub { $create_64_classes->($_[0], 0, 0) };
    }
    *BFloat64= sub { return $primitive_class->create($_[0], 8, "d") };
    *LFloat64= sub { return $reversed_class->create($_[0], 8, "d") };
}

sub Struct  { return Data::ParseBinary::Struct->create(@_) }
sub Sequence{ return Data::ParseBinary::Sequence->create(@_) };
sub Array {
    my ($count, $sub) = @_;
    if ($count and ref($count) and UNIVERSAL::isa($count, "CODE")) {
        return Data::ParseBinary::MetaArray->create($count, $sub);
    } else {
        return Data::ParseBinary::MetaArray->create(sub {$count}, $sub);
    }
}

sub GreedyRange { return Data::ParseBinary::Range->create(1, undef, $_[0]); }
sub OptionalGreedyRange { return Data::ParseBinary::Range->create(0, undef, $_[0]); }
sub Range { return Data::ParseBinary::Range->create(@_) };
sub Padding   { return Data::ParseBinary::Padding->create($_[0]) }
sub Flag      { return Data::ParseBinary::BitField->create($_[0], 1) }
sub Bit       { return Data::ParseBinary::BitField->create($_[0], 1) }
sub Nibble    { return Data::ParseBinary::BitField->create($_[0], 4) }
sub Octet     { return Data::ParseBinary::BitField->create($_[0], 8) }
sub BitField  { return Data::ParseBinary::BitField->create(@_) }
sub ReversedBitField { return Data::ParseBinary::ReversedBitField->create(@_) }

sub ConditionalRestream { return Data::ParseBinary::ConditionalRestream->create(@_) }
sub BitStruct {
    my ($name, @subcons) = @_;
    my $subcon = Struct($name, @subcons);
    return ConditionalRestream($subcon, "Bit", sub { not $_->stream->isBitStream() });
}
sub ReversedBitStruct {
    my ($name, @subcons) = @_;
    my $subcon = Struct($name, @subcons);
    return ConditionalRestream($subcon, "ReversedBit", sub { not $_->stream->isBitStream() });
}
sub Enum      { return Data::ParseBinary::Enum->create(@_) }
sub OneOf {
    my ($subcon, $list) = @_;
    my $code = sub {
        return grep $_ == $_[0], @$list;
    };
    return Data::ParseBinary::LamdaValidator->create($subcon, $code);
}
sub NoneOf {
    my ($subcon, $list) = @_;
    my $code = sub {
        my @res = grep $_ == $_[0], @$list;
        return @res == 0;
    };
    return Data::ParseBinary::LamdaValidator->create($subcon, $code);
}
sub Field {
    my ($name, $len) = @_;
    if ($len and ref($len) and UNIVERSAL::isa($len, "CODE")) {
        return Data::ParseBinary::MetaField->create($name, $len);
    } else {
        return Data::ParseBinary::StaticField->create($name, $len);
    }
}
*Bytes = \&Field;
sub RepeatUntil (&$) { return Data::ParseBinary::RepeatUntil->create(@_) }

sub Char {
    my ($name, $encoding) = @_;

    # if we don't have encoding - a char is simply one byte
    return Field($name, 1) unless $encoding;

    if ( ( $encoding eq "UTF-32LE" ) or ( $encoding eq "UTF-32BE" ) ) {
        my $subcon = Field($name, 4);
        return Data::ParseBinary::CharacterEncodingAdapter->create($subcon, $encoding);
    } elsif ( ( $encoding eq "UTF-16LE" ) or ( $encoding eq "UTF-16BE" ) ) {
        my $place = $encoding eq "UTF-16LE" ? 1 : 0;
        my $subcon = Struct($name,
                            Field("FirstUnit", 2),
                            Array( sub { my $ch = substr($_->ctx->{FirstUnit}, $place, 1); return ( ( ($ch ge "\xD8" ) and ($ch le "\xDB") ) ? 1 : 0 ) },
                                  Field("TheRest", 2)
                                  )
                            );
        my $assambled = Data::ParseBinary::FirstUnitAndTheRestAdapter->create($subcon, 2);
        return Data::ParseBinary::CharacterEncodingAdapter->create($assambled, $encoding);
    } elsif ( ( $encoding eq "utf8" ) or ( $encoding eq "UTF-8" ) ) {
        my $subcon = Struct($name,
                            Field("FirstUnit", 1),
                            Array( sub { my $ch = $_->ctx->{FirstUnit}; return scalar(grep { $ch ge $_ } "\xC0", "\xE0", "\xF0" ) || 0 },
                                  Field("TheRest", 1)
                                  )
                            );
        my $assambled = Data::ParseBinary::FirstUnitAndTheRestAdapter->create($subcon, 1);
        return Data::ParseBinary::CharacterEncodingAdapter->create($assambled, $encoding);
    } elsif ( $encoding =~ /^(?:utf|ucs)/i ) {
        die "Unrecognized UTF format: $encoding";
    } else {
        # this is a single-byte encoding
        return Data::ParseBinary::CharacterEncodingAdapter->create(Field($name, 1), $encoding);
    }
}

sub PaddedString {
    my ($name, $length, %params) = @_;
    my $subcon = Data::ParseBinary::PaddedStringAdapter->create(Field($name, $length), length => $length, %params);
    return $subcon unless $params{encoding};
    return Data::ParseBinary::CharacterEncodingAdapter->create($subcon, $params{encoding});
};
sub String {
    my ($name, $length, %params) = @_;
    if (defined $params{padchar}) {
        #this is a padded string
        return PaddedString($name, $length, %params);
    }
    return Data::ParseBinary::JoinAdapter->create(
        Array($length, Char($name, $params{encoding})),
    );
}
sub LengthValueAdapter { return Data::ParseBinary::LengthValueAdapter->create(@_) }
sub PascalString {
    my ($name, $length_field_type, $encoding) = @_;
    $length_field_type ||= \&UBInt8;
    my $length_field;
    {
        no strict 'refs';
        $length_field = &$length_field_type('length');
    }
    if (not $encoding) {
        return LengthValueAdapter(
            Sequence($name,
                $length_field,
                Field("data", sub { $_->ctx->[0] }),
            )
        );
    } else {
        return LengthValueAdapter(
            Sequence($name,
                $length_field,
                Data::ParseBinary::JoinAdapter->create(
                    Array(sub { $_->ctx->[0] }, Char("data", $encoding)),
                ),
            )
        );
    }
}

sub CString {
    my ($name, %params) = @_;
    my ($terminators, $encoding, $char_field) = @params{qw{terminators encoding char_field}};
    $terminators = "\x00" unless defined $terminators;
    $char_field ||= Char($name, $encoding);
    my @t_list = split '', $terminators;
    return Data::ParseBinary::CStringAdapter->create(
        Data::ParseBinary::JoinAdapter->create(
            RepeatUntil(sub { my $obj = $_->obj; grep($obj eq $_, @t_list) } ,$char_field)),
            $terminators
        );
}


sub Switch { return Data::ParseBinary::Switch->create(@_) }
sub Pointer { return Data::ParseBinary::Pointer->create(@_) }
sub LazyBound { return Data::ParseBinary::LazyBound->create(@_) }
sub Value { return Data::ParseBinary::Value->create(@_) }
sub Anchor { my $name = shift; return Value($name, sub { $_->stream->tell } ) }
sub Terminator { return Data::ParseBinary::Terminator->create() }

sub IfThenElse {
    my ($name, $predicate, $then_subcon, $else_subcon) = @_;
    return Switch($name, sub { &$predicate ? 1 : 0 },
        {
            1 => $then_subcon,
            0 => $else_subcon,
        }
    )
}

sub If {
    my ($predicate, $subcon, $elsevalue) = @_;
    return IfThenElse($subcon->_get_name(),
        $predicate,
        $subcon,
        Value("elsevalue", sub { $elsevalue })
    )
}
sub Peek { Data::ParseBinary::Peek->create(@_) }
sub Const { Data::ParseBinary::ConstAdapter->create(@_) }
sub Alias {
    my ($newname, $oldname) = @_;
    return Value($newname, sub { $_->ctx->{$oldname}});
}

sub Union { Data::ParseBinary::Union->create(@_) }
sub RoughUnion { Data::ParseBinary::RoughUnion->create(@_) }

*CreateStreamReader = \&Data::ParseBinary::Stream::Reader::CreateStreamReader;
*CreateStreamWriter = \&Data::ParseBinary::Stream::Writer::CreateStreamWriter;
sub ExtractingAdapter { Data::ParseBinary::ExtractingAdapter->create(@_) };

sub Aligned {
    my ($subcon, $modulus) = @_;
    $modulus ||= 4;
    die "Aligned should be more then 2" if $modulus < 2;
    my $sub_name = $subcon->_get_name();
    my $s = ExtractingAdapter(
        Struct($sub_name,
               Anchor("Aligned_before"),
               $subcon,
               Anchor("Aligned_after"),
               Padding(sub { ($modulus - (($_->ctx->{Aligned_after} - $_->ctx->{Aligned_before}) % $modulus)) % $modulus })
              ),
        $sub_name);
    return $s;
}

sub Restream {
    my ($subcon, $stream_name) = @_;
    return Data::ParseBinary::Restream->create($subcon, $stream_name);
}
sub Bitwise {
    my ($subcon) = @_;
    return Restream($subcon, "Bit");
}

sub Magic {
    my ($data) = @_;
    return Const(Field(undef, length($data)), $data);
}

sub Select { Data::ParseBinary::Select->create(@_) }

sub Optional {
    my $subcon = shift;
    return Select($subcon, $DefaultPass);
}

sub FlagsEnum { Data::ParseBinary::FlagsEnum->create(@_) }

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(
    UBInt8
    ULInt8
    SBInt8
    SLInt8
    Byte
    UBInt16
    ULInt16
    SBInt16
    SLInt16
    UBInt32
    ULInt32
    SBInt32
    SLInt32
    BFloat32
    LFloat32
    UBInt64
    ULInt64
    SBInt64
    SLInt64
    BFloat64
    LFloat64

    Struct
    Sequence

    Padding

    Flag
    Bit
    Nibble
    Octet
    BitField
    BitStruct
    ReversedBitField
    ReversedBitStruct

    Enum
    $DefaultPass
    OneOf
    NoneOf
    Array
    RepeatUntil
    Field
    Bytes
    Switch
    Pointer
    Anchor

    Char
    String
    PascalString
    CString
    PaddedString

    LazyBound
    Value
    IfThenElse
    If
    Peek
    Const
    Terminator
    Alias
    Union
    RoughUnion

    CreateStreamReader
    CreateStreamWriter

    Aligned
    ExtractingAdapter
    Restream
    Bitwise
    Magic

    Select
    FlagsEnum
);

our @Neturals_depricated = qw{
    UNInt8
    SNInt8
    UNInt16
    SNInt16
    UNInt32
    SNInt32
    UNInt64
    SNInt64
    NFloat32
    NFloat64
};
our @EXPORT_OK = (@Neturals_depricated, qw{
    Range
    GreedyRange
    OptionalGreedyRange
    Optional
});
our %EXPORT_TAGS = ( NATURALS => \ @Neturals_depricated, all => [ @EXPORT_OK, @EXPORT ]);

1;

__END__