Data-ParseBinary-0.31~dfsg/0000755000000000000000000000000011535704021014261 5ustar rootrootData-ParseBinary-0.31~dfsg/t/0000755000000000000000000000000011763237127014537 5ustar rootrootData-ParseBinary-0.31~dfsg/t/04encodings.t0000755000000000000000000000706611142044330017034 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Data::Dumper; use Data::ParseBinary; #use Test::More tests => 177; #use Test::More qw(no_plan); use Test::More; eval { require Encode; }; if ($@) { plan skip_all => 'This suit needs Encode'; } else { plan tests => 38; } $| = 1; my ($ch, $oc, $s); $s = Char("c", "utf8"); $ch = "a"; $oc = "a"; ok( $s->build($ch) eq $oc, "Char utf8: Build: Simple"); ok( $s->parse($oc) eq $ch, "Char utf8: Parse: Simple"); $ch = "\x{1abcd}"; $oc = "\xf0\x9a\xaf\x8d"; ok( $s->build($ch) eq $oc, "Char utf8: Build: four bytes"); ok( $s->parse($oc) eq $ch, "Char utf8: Parse: four bytes"); $ch = "\x{20AC}"; $oc = "\xE2\x82\xAC"; ok( $s->build($ch) eq $oc, "Char utf8: Build: three bytes"); ok( $s->parse($oc) eq $ch, "Char utf8: Parse: three bytes"); $ch = "\x{0430}"; $oc = "\xD0\xB0"; ok( $s->build($ch) eq $oc, "Char utf8: Build: two bytes"); ok( $s->parse($oc) eq $ch, "Char utf8: Parse: two bytes"); $s = Char("c", "UTF-16BE"); $ch = "\x{0430}"; $oc = "\x04\x30"; ok( $s->build($ch) eq $oc, "Char UTF-16BE: Build: single"); ok( $s->parse($oc) eq $ch, "Char UTF-16BE: Parse: single"); $ch = "\x{1abcd}"; $oc = "\xD8\x2A\xDF\xCD"; ok( $s->build($ch) eq $oc, "Char UTF-16BE: Build: Surrogate Pairs"); ok( $s->parse($oc) eq $ch, "Char UTF-16BE: Parse: Surrogate Pairs"); $s = Char("c", "UTF-16LE"); $ch = "\x{0430}"; $oc = "\x30\x04"; ok( $s->build($ch) eq $oc, "Char UTF-16LE: Build: single"); ok( $s->parse($oc) eq $ch, "Char UTF-16LE: Parse: single"); $ch = "\x{1abcd}"; $oc = "\x2A\xD8\xCD\xDF"; ok( $s->build($ch) eq $oc, "Char UTF-16LE: Build: Surrogate Pairs"); ok( $s->parse($oc) eq $ch, "Char UTF-16LE: Parse: Surrogate Pairs"); $s = Char("c", "UTF-32BE"); $ch = "\x{0430}"; $oc = "\0\0\x04\x30"; ok( $s->build($ch) eq $oc, "Char UTF-32BE: Build: single"); ok( $s->parse($oc) eq $ch, "Char UTF-32BE: Parse: single"); $ch = "\x{1abcd}"; $oc = "\0\1\xAB\xCD"; ok( $s->build($ch) eq $oc, "Char UTF-32BE: Build: high char"); ok( $s->parse($oc) eq $ch, "Char UTF-32BE: Parse: high char"); $s = Char("c", "UTF-32LE"); $ch = "\x{0430}"; $oc = "\x30\x04\0\0"; ok( $s->build($ch) eq $oc, "Char UTF-32LE: Build: single"); ok( $s->parse($oc) eq $ch, "Char UTF-32LE: Parse: single"); $ch = "\x{1abcd}"; $oc = "\xCD\xAB\1\0"; ok( $s->build($ch) eq $oc, "Char UTF-32LE: Build: high char"); ok( $s->parse($oc) eq $ch, "Char UTF-32LE: Parse: high char"); foreach my $enc (qw{UTF-32 utf UTF-16 UTF UTF8 ucs-2}) { eval { Char("c", $enc) }; ok( $@, "Char died on encoding: $enc"); } $s = Char("c", "iso-8859-8"); $ch = "\x{05D0}"; # the letter "Alef" in hebrew, in unicode $oc = "\xE0"; # the same in iso-8859-8 ok( $s->build($ch) eq $oc, "Char hebrew: Build: simple"); ok( $s->parse($oc) eq $ch, "Char hebrew: Parse: simple"); my $love_decoded = "\x{05D0}\x{05D4}\x{05D1}\x{05D4}"; my $love_encoded = "\xd7\x90\xd7\x94\xd7\x91\xd7\x94"; $s = PaddedString("foo", 10, encoding => "utf8", padchar => "\0"); $oc = $love_encoded."\0\0"; ok( $s->build($love_decoded) eq $oc, "String: Build: love"); ok( $s->parse($oc) eq $love_decoded, "String: Parse: love"); $s = PascalString("foo", undef, "utf8"); $oc = "\x04".$love_encoded; ok( $s->build($love_decoded) eq $oc, "PascalString: Build: love"); ok( $s->parse($oc) eq $love_decoded, "PascalString: Parse: love"); $s = CString("foo", encoding => "utf8"); $oc = $love_encoded."\0"; ok( $s->build($love_decoded) eq $oc, "CString: Build: love"); ok( $s->parse($oc) eq $love_decoded, "CString: Parse: love"); Data-ParseBinary-0.31~dfsg/t/01various.t0000755000000000000000000005104111525753137016561 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Data::Dumper; use Data::ParseBinary; use Test::More; $| = 1; my $data; my $string; my $s; my $s1; ok( UBInt16("foo")->parse("\x01\x02") == 258, "Primitive: Parse: UBInt16"); ok( ULInt16("foo")->parse("\x01\x02") == 513, "Primitive: Parse: ULInt16"); ok( UBInt16("foo")->build(31337) eq 'zi', "Primitive: Build: UBInt16"); ok( SBInt16("foo")->build(-31337) eq "\x85\x97", "Primitive: Build: SBInt16"); ok( SLInt16("foo")->build(-31337) eq "\x97\x85", "Primitive: Build: SLInt16"); ok( BFloat32("foo")->build(5) eq "\x40\xa0\0\0", "Primitive: Build: BFloat32"); ok( LFloat32("foo")->build(5) eq "\0\0\xa0\x40", "Primitive: Build: LFloat32"); ok( BFloat32("foo")->parse("\x40\xa0\0\0") == 5, "Primitive: Parse: BFloat32"); ok( LFloat64("foo")->build(5) eq "\0\0\0\0\0\0\x14\x40", "Primitive: Build: LFloat64"); ok( LFloat64("foo")->parse("\0\0\0\0\0\0\x14\x40") == 5, "Primitive: Build: LFloat64"); $s = Struct("foo", UBInt8("a"), SLInt16("b") ); $data = {a => 7, b => 256}; $string = "\x07\x00\x01"; is_deeply($s->parse($string), $data, "Struct: Parse: correct"); ok( $s->build($data) eq $string, "Struct: Build: Rebuild1"); $data->{b} = 5000; ok( $s->build($data) eq "\x07\x88\x13", "Struct: Build: Rebuild2"); $s = Struct("foo", UBInt8("a"), UBInt16("b"), Struct("bar", UBInt8("a"), UBInt16("b"), ) ); $data = {a=>65, b=>16962, bar=>{ a=>97, b=> 25186}}; $string = "ABBabb"; is_deeply($s->parse($string), $data, "Nested Struct: Parse: correct"); ok( $s->build($data) eq $string, "Nested Struct: Build: Rebuild1"); $s = Sequence("foo", UBInt8("a"), UBInt16("b") ); $data = [97, 25186]; $string = "abb"; is_deeply($s->parse($string), $data, "Sequence: Parse: correct"); ok( $s->build($data) eq $string, "Sequence: Build: Rebuild1"); ok( $s->build([1,2]) eq "\x01\x00\x02", "Sequence: Build: correct"); $s = Sequence("foo", UBInt8("a"), UBInt16("b"), Sequence("bar", UBInt8("a"), UBInt16("b"), ) ); $data = [65, 16962, [97, 25186]]; $string = "ABBabb"; is_deeply($s->parse($string), $data, "Nested Sequence: Parse: correct"); ok( $s->build($data) eq $string, "Nested Sequence: Build: correct"); $s = Array(4, UBInt8("foo")); $data = $s->parse("\x01\x02\x03\x04"); is_deeply( $s->parse("\x01\x02\x03\x04"), [1..4], "StrictRepeater: Parse: correct elements1"); eval { $data = $s->parse("\x01\x02\x03") }; ok( $@ , "StrictRepeater: Parse: Die on too few elements"); is_deeply( $s->parse("\x01\x02\x03\x04\x05"), [1..4], "StrictRepeater: Parse: correct elements2"); ok( $s->build([5,6,7,8]) eq "\x05\x06\x07\x08", "StrictRepeater: Build: normal build"); eval { $s->build([5,6,7,8,9]) }; ok( $@, "StrictRepeater: Build: dies on too many elements"); $s = Array(5, Array(2, UBInt8("foo"))); $data = [[97,97], [98,98], [99,99], [100,100], [101,101]]; $string = "aabbccddee"; is_deeply($s->parse($string), $data, "Nested StrictRepeater: Parse: correct"); ok( $s->build($data) eq $string, "Nested StrictRepeater: Build: correct"); $s = Struct("foo", Padding(2), Flag("myflag"), Padding(5), ); $data = {myflag => 1}; $string = "\x00\x00\x01\x00\x00\x00\x00\x00"; is_deeply($s->parse($string), $data, "Struct with Padding, Flag: Parse: correct"); ok( $s->build($data) eq $string, "Struct with Padding, Flag: Build: correct"); $s = BitStruct("foo", Padding(2), Flag("myflag"), Padding(5), ); $data = {myflag => 1}; $string = "\x20"; is_deeply($s->parse($string), $data, "BitStruct with Padding, Flag: Parse: correct"); ok( $s->build($data) eq $string, "BitStruct with Padding, Flag: Build: correct"); $s = BitStruct("foo", BitField("a", 3), Flag("b"), Padding(3), Nibble("c"), BitField("d", 5), ); $data = {a=>7, b=>0, c=>8, d=>31}; $string = "\xe1\x1f"; is_deeply($s->parse($string), $data, "BitStruct: Parse: correct"); ok( $s->build($data) eq $string, "BitStruct: Build: correct"); $s = BitStruct("foo", BitField("a", 3), Flag("b"), Padding(3), Nibble("c"), Struct("bar", Nibble("d"), Bit("e"), ) ); $data = { a=>7, b=>0, c=>8, bar=>{ d=>15, e=>1 } }; $string = "\xe1\x1f"; is_deeply($s->parse($string), $data, "Nested BitStruct: Parse: correct"); ok($s->build($data) eq $string, "Nested BitStruct: Build: correct"); $s = BitStruct("foo", BitField("a", 3), Flag("b"), Byte("c"), ); $data = { a=>7, b=>0, c=>59 }; $string = "\xe3\xb0"; is_deeply($s->parse($string), $data, "BitStruct with Byte: Parse: correct"); ok( $s->build($data) eq $string, "BitStruct with Byte: Build: correct"); $s = Enum(Byte("protocol"), TCP => 6, UDP => 17, ); ok( $s->parse("\x06") eq 'TCP', "Enum: correct1"); ok( $s->parse("\x11") eq 'UDP', "Enum: correct1"); eval { $s->parse("\x12") }; ok( $@, "Enum: dies on undeclared value with default"); ok( $s->build("TCP") eq "\x06", "Enum: build 1"); ok( $s->build("UDP") eq "\x11", "Enum: build 2"); $s = Enum(Byte("protocol"), TCP => 6, UDP => 17, _default_ => blah => 99, ); ok( $s->parse("\x11") eq 'UDP', "Enum with default: correct1"); ok( $s->parse("\x12") eq 'blah', "Enum with default: correct2"); ok( $s->build("TCP") eq "\x06", "Enum with default: build 1"); ok( $s->build("blah") eq "\x63", "Enum with default: build default"); $s = Enum(Byte("protocol"), TCP => 6, UDP => 17, _default_ => $DefaultPass, ); ok( $s->parse("\x11") eq 'UDP', "Enum with pass: correct1"); ok( $s->parse("\x12") == 18, "Enum with pass: correct2"); ok( $s->parse("\xff") == 255, "Enum with pass: correct3"); ok( $s->build("TCP") eq "\x06", "Enum with pass: build 1"); ok( $s->build(18) eq "\x12", "Enum with pass: build 2"); ok( $s->build(255) eq "\xff", "Enum with pass: build 3"); ok( OneOf(UBInt8("foo"), [4,5,6,7])->parse("\x05") == 5, "OneOf: Parse: passing"); eval { OneOf(UBInt8("foo"), [4,5,6,7])->parse("\x08") }; ok( $@, "OneOf: Parse: blocking"); ok( OneOf(UBInt8("foo"), [4,5,6,7])->build(5) eq "\x05", "OneOf: Build: passing"); eval { OneOf(UBInt8("foo"), [4,5,6,7])->build(8) }; ok( $@, "OneOf: Build: blocking"); ok( NoneOf(UBInt8("foo"), [4,5,6,7])->parse("\x08") == 8, "NoneOf: Parse: passing"); eval { NoneOf(UBInt8("foo"), [4,5,6,7])->parse("\x06") }; ok( $@, "NoneOf: Parse: blocking"); ok( NoneOf(UBInt8("foo"), [4,5,6,7])->build(8) eq "\x08", "NoneOf: Build: passing"); eval { NoneOf(UBInt8("foo"), [4,5,6,7])->build(6) }; ok( $@, "NoneOf: Build: blocking"); $s = Struct("foo", Byte("length"), Field("data", sub { $_->ctx->{length} }), ); $data = {data=> 'ABC', length => 3}; $string = "\x03ABC"; is_deeply( $s->parse($string), $data, "MetaField: Parse: correct1"); ok( $s->build($data) eq $string, "MetaField: Build: correct1"); $data = {data=> 'ABCD', length => 4}; $string = "\x04ABCD"; is_deeply( $s->parse($string), $data, "MetaField: Parse: correct2"); ok( $s->build($data) eq $string, "MetaField: Build: correct2"); ok( Field("foo", 3)->parse("ABCD") eq "ABC", "Field: Parse: route to StaticField"); ok( Field("foo", sub {return 3})->parse("ABCD") eq "ABC", "Field: Parse: route to MetaField"); $s = Struct("foo", Byte("length"), Array(sub { $_->ctx->{length}}, UBInt16("data")), ); $data = {length => 3, data => [1,2,3]}; $string = "\x03\x00\x01\x00\x02\x00\x03"; is_deeply( $s->parse($string), $data, "MetaRepeater: Parse: correct"); ok( $s->build($data) eq $string, "MetaRepeater: Build: correct"); $s = RepeatUntil(sub {$_->obj eq "\x00"}, Field("data", 1)); $data = [ split('', "abcdef\x00") ]; $string = "abcdef\x00this is another string"; is_deeply( $s->parse($string), $data, "RepeatUntil: Parse: correct"); $string = "abcdef\x00"; ok( $s->build($data) eq $string, "RepeatUntil: Build: correct"); $s = Struct("foo", Enum(Byte("type"), INT1 => 1, INT2 => 2, INT4 => 3, STRING => 4, ), Switch("data", sub { $_->ctx->{type} }, { "INT1" => UBInt8("spam"), "INT2" => UBInt16("spam"), "INT4" => UBInt32("spam"), "STRING" => String("spam", 6), } ) ); $data = {type => 'INT1', data => 18}; $string = "\x01\x12"; is_deeply( $s->parse($string), $data, "Switch: Parse: correct1"); ok( $s->build($data) eq $string, "Switch: Build: correct1"); $data = {type => 'INT2', data => 4660}; $string = "\x02\x12\x34"; is_deeply( $s->parse($string), $data, "Switch: Parse: correct2"); ok( $s->build($data) eq $string, "Switch: Build: correct2"); $data = {type => 'INT4', data => 305419896}; $string = "\x03\x12\x34\x56\x78"; is_deeply( $s->parse($string), $data, "Switch: Parse: correct3"); ok( $s->build($data) eq $string, "Switch: Build: correct3"); $data = {type => 'STRING', data => 'abcdef'}; $string = "\x04abcdef"; is_deeply( $s->parse($string), $data, "Switch: Parse: correct4"); ok( $s->build($data) eq $string, "Switch: Build: correct4"); $s = Struct("foo", Byte("type"), Switch("data", sub { $_->ctx->{type} }, { 1 => UBInt8("spam"), 2 => UBInt16("spam"), }, default => UBInt8("spam") ) ); $data = {type => 1, data => 255}; $string = "\x01\xff"; is_deeply( $s->parse($string), $data, "Switch with default: Parse: correct1"); ok( $s->build($data) eq $string, "Switch with default: Build: correct1"); $data = {type => 2, data => 65535}; $string = "\x02\xff\xff"; is_deeply( $s->parse($string), $data, "Switch with default: Parse: correct2"); ok( $s->build($data) eq $string, "Switch with default: Build: correct2"); $data = {type => 3, data => 255}; $string = "\x03\xff\xff"; # <-- uses the default construct is_deeply( $s->parse($string), $data, "Switch with default: Parse: correct3"); ok( $s->build($data) eq "\x03\xff", "Switch with default: Build: correct3"); $s = Struct("foo", Byte("type"), Switch("data", sub { $_->ctx->{type} }, { 1 => UBInt8("spam"), 2 => UBInt16("spam"), }, default => $DefaultPass, ) ); $data = {type => 1, data => 255}; $string = "\x01\xff"; is_deeply( $s->parse($string), $data, "Switch with pass: Parse: correct1"); ok( $s->build($data) eq $string, "Switch with pass: Build: correct1"); $data = {type => 2, data => 65535}; $string = "\x02\xff\xff"; is_deeply( $s->parse($string), $data, "Switch with pass: Parse: correct2"); ok( $s->build($data) eq $string, "Switch with pass: Build: correct2"); $data = {type => 3, data => undef}; $string = "\x03\xff\xff"; # <-- uses the default construct is_deeply( $s->parse($string), $data, "Switch with pass: Parse: correct3"); ok( $s->build($data) eq "\x03", "Switch with pass: Build: correct3"); $s = Struct("foo", Pointer(sub { 4 }, Byte("data1")), # <-- data1 is at (absolute) position 4 Pointer(sub { 7 }, Byte("data2")), # <-- data2 is at (absolute) position 7 ); $data = {data1 => 1, data2=> 2}; $string = "\x00\x00\x00\x00\x01\x00\x00\x02"; is_deeply( $s->parse($string), $data, "Pointer: Parse: correct"); ok( $s->build($data) eq $string, "Pointer: Build: Empty"); $s = Struct("foo", Byte("padding_length"), Padding(sub { $_->ctx->{padding_length} } ), Byte("relative_offset"), Anchor("absolute_position"), Pointer(sub { $_->ctx->{absolute_position} + $_->ctx->{relative_offset} }, Byte("data")), ); $data = {relative_offset=>3, absolute_position=>7, data=>255, padding_length=>5}; $string = "\x05\x00\x00\x00\x00\x00\x03\x00\x00\x00\xff"; is_deeply( $s->parse($string), $data, "Pointer n Anchor: Parse: Correct"); ok(( $s->build($data) eq $string ), "Pointer n Anchor: Build: Correct"); $s = Struct("foo", Byte("padding_length"), Padding(sub { $_->ctx->{padding_length} } ), Byte("relative_offset"), Pointer(sub { $_->stream->tell + $_->ctx->{relative_offset} }, Byte("data")), ); $data = {relative_offset=>3, data=>255, padding_length=>5}; $string = "\x05\x00\x00\x00\x00\x00\x03\x00\x00\x00\xff"; is_deeply( $s->parse($string), $data, "Pointer n Anchor: Parse: Correct"); ok(( $s->build($data) eq $string ), "Pointer n Anchor: Build: Correct"); ok(( String("foo", 5)->parse("hello") eq "hello"), "String: Parse: Simple"); $s = String("foo", 10, padchar => "X", paddir => "right"); ok(( $s->parse("helloXXXXX") eq 'hello' ), "Padded String: Parse: Simple"); ok(( $s->build("hello") eq 'helloXXXXX' ), "Padded String: Build: Simple"); $s = PascalString("foo"); ok(( $s->parse("\x05hello") eq 'hello'), "PascalString: Parse: Simple"); ok(( $s->build("hello world") eq "\x0bhello world"), "PascalString: Build: Simple"); $s = PascalString("foo", \&UBInt16); ok(( $s->parse("\x00\x05hello") eq 'hello'), "PascalString: Parse: With cutsom length type"); ok(( $s->build("hello") eq "\x00\x05hello"), "PascalString: Build: With cutsom length type"); $s = CString("foo"); ok(( $s->parse("hello\x00") eq 'hello' ), "CString: Parse: Simple"); ok(( $s->build("hello") eq "hello\x00" ), "CString: Build: Simple"); $s = CString("foo", terminators => "XYZ"); ok(( $s->parse("helloX") eq 'hello' ), "CString: Parse: custom terminator1"); ok(( $s->parse("helloY") eq 'hello' ), "CString: Parse: custom terminator2"); ok(( $s->parse("helloZ") eq 'hello' ), "CString: Parse: custom terminator3"); ok(( $s->build("hello") eq "helloX" ), "CString: Build: custom terminator"); $s = Struct("foo", UBInt8("width"), UBInt8("height"), Value("total_pixels", sub { $_->ctx->{width} * $_->ctx->{height}}), ); is_deeply( $s->parse("\x05\x05"), { width => 5, height => 5, total_pixels => 25 }, "Value: Parse: Simple"); $data = { width => 5, height => 5 }; ok(( $s->build($data) eq "\x05\x05"), "Value: Parse: Ignored"); is_deeply( $data, { width => 5, height => 5, total_pixels => 25 }, "Value: Parse: Added to hash"); $s = Struct("foo", Flag("has_options"), If(sub { $_->ctx->{has_options} }, Bytes("options", 5) ) ); is_deeply( $s->parse("\x01hello"), {options => 'hello', has_options => 1 }, "If: Parse: True"); is_deeply( $s->parse("\x00hello"), {options => undef, has_options => 0 }, "If: Parse: False"); ok(( $s->build({options => undef, has_options => 0 }) eq "\0"), "If: Build: False"); ok(( $s->build({options => 'hello', has_options => 1 }) eq "\x01hello"), "If: Build: True"); $s = Struct("foo", Flag("long_options"), IfThenElse("options", sub { $_->ctx->{long_options} }, Bytes("Long Options", 5), Bytes("Short Options", 3), ), ); is_deeply( $s->parse("\x01hello"), {options => 'hello', long_options => 1 }, "IfThenElse: Parse: True"); is_deeply( $s->parse("\x00hello"), {options => 'hel', long_options => 0 }, "IfThenElse: Parse: False"); ok(( $s->build({options => 'hel', long_options => 0 }) eq "\0hel"), "IfThenElse: Build: False"); ok(( $s->build({options => 'hello', long_options => 1 }) eq "\x01hello"), "IfThenElse: Build: True"); $s = Struct("foo", Flag("has_next"), If(sub { $_->ctx->{has_next} }, LazyBound("next", sub { $s })), ); $data = { has_next => 1, next => { has_next => 1, next => { has_next => 1, next => { has_next => 0, next => undef } } } }; $string = "\x01\x01\x01\x00"; is_deeply( $s->parse($string), $data, "LazyBound: Parse: Correct"); ok(( $s->build($data) eq $string), "LazyBound: Build: Correct"); $s = Struct("foo", Byte("a"), Peek(Byte("b")), Byte("c"), ); is_deeply( $s->parse("\x01\x02"), {a=>1, b=>2, c=>2}, "Peek: Parse: Simple"); ok(( $s->build({a=>1, b=>222, c=>2}) eq "\x01\x02"), "Peek: Build: Ignored"); $s = Struct("foo", Byte("a"), Peek(Byte("b"), 3), UBInt16("c"), Byte("d"), Byte("e"), ); $string = "\x01\xaa\xbb\x03\x04"; $data = {a=>1, c=>43707, d=>3, e=>4}; is_deeply( $s->parse($string), {%$data, b=>4}, "Far Peek: Parse: Simple"); ok(( $s->build($data) eq $string), "Far Peek: Build: Ignored"); $s = Const(Bytes("magic", 6), "FOOBAR"); ok(($s->parse("FOOBAR") eq "FOOBAR"), "Const: Parse: OK"); eval { $s->parse("FOOBAX") }; ok( $@, "Const: Parse: Dies"); ok(( $s->build("FOOBAR") eq "FOOBAR"), "Const: Build: OK"); eval { $s->build("FOOBAX") }; ok( $@, "Const: Build: Dies"); $s = Terminator(); ok(( not defined $s->parse("")), "Terminator: Parse: ok"); eval { $s->parse("x") }; ok( $@, "Terminator: Parse: dies"); ok(( $s->build({}) eq ""), "Terminator: Build: Empty"); $s = Struct("foo", Byte("a"), Alias("b", "a"), ); is_deeply( $s->parse("\x03"), {a=>3, b=>3}, "Alias: Parse: Simple"); $data = {a=>3}; ok(( $s->build($data) eq "\x03"), "Alias: Build: OK"); is_deeply($data, {a=>3, b=>3}, "Alias: Build: Add value"); $data = {a=>3, b=>5}; ok(( $s->build($data) eq "\x03"), "Alias: Build: Ignore b"); $s = Union("foo", UBInt32("a"), UBInt16("b") ); is_deeply( $s->parse("\xaa\xbb\xcc\xdd"), { a => 2864434397, b => 43707 }, "Union: Parse: Simple"); ok(( $s->build( { a=> 2864434397 } ) eq "\xaa\xbb\xcc\xdd" ), "Union: Build: a"); ok(( $s->build( { b => 43707 } ) eq "\xaa\xbb\0\0" ), "Union: Build: b"); $s = Struct("foo", Aligned(Byte("bbb"), 8), Byte("aaa")); $data = { bbb => 99, aaa=>5 }; $string = "c\0\0\0\0\0\0\0\5"; is_deeply( $s->parse($string), $data, "Aligned: Parse: Correct"); ok(( $s->build($data) eq $string), "Aligned: Build: Correct"); $s = Bitwise(Struct("foo", Padding(2), Flag("myflag"), Padding(5), )); $data = {myflag => 1}; $string = "\x20"; is_deeply($s->parse($string), $data, "Bitwise eq BitStruct: Parse: correct"); ok( $s->build($data) eq $string, "Bitwise eq BitStruct: Build: correct"); $s = Struct("foo1", Byte("a"), Select( Const(Byte("b1"), 4), Const(Byte("b2"), 2), ), Byte("c"), ); $s1 = Struct("foo1", Byte("a"), Select( Const(Byte("b1"), 4), Const(Byte("b2"), 2), $DefaultPass, ), Byte("c"), ); $string = "\3\4\xb0"; $data = { a=>3, b1=>4, c=>176}; is_deeply($s->parse($string), $data, "Select: Parse: OK1"); ok( $s->build($data) eq $string, "Select: Build: OK1"); is_deeply($s1->parse($string), $data, "Select with Pass: Parse: OK1"); ok( $s1->build($data) eq $string, "Select with Pass: Build: OK1"); $string = "\3\2\xb0"; $data = { a=>3, b2=>2, c=>176}; is_deeply($s->parse($string), $data, "Select: Parse: OK2"); ok( $s->build($data) eq $string, "Select: Build: OK2"); is_deeply($s1->parse($string), $data, "Select with Pass: Parse: OK2"); ok( $s1->build($data) eq $string, "Select with Pass: Build: OK2"); $string = "\3\3\xb0"; $data = { a=>3, b2=>3, c=>176}; eval { $s->parse($string) }; ok( $@, "Select: Parse: Failed"); eval { $s->build($data) }; ok( $@, "Select: Build: Failed"); $data = { a=>3, c=>3}; is_deeply($s1->parse($string), $data, "Select with Pass: Parse: Pass"); ok( $s1->build($data) eq "\3\3", "Select with Pass: Build: Pass"); $s = FlagsEnum(ULInt16("characteristics"), RELOCS_STRIPPED => 0x0001, EXECUTABLE_IMAGE => 0x0002, LINE_NUMS_STRIPPED => 0x0004, LOCAL_SYMS_STRIPPED => 0x0008, AGGRESSIVE_WS_TRIM => 0x0010, LARGE_ADDRESS_AWARE => 0x0020, MACHINE_16BIT => 0x0040, BYTES_REVERSED_LO => 0x0080, MACHINE_32BIT => 0x0100, DEBUG_STRIPPED => 0x0200, REMOVABLE_RUN_FROM_SWAP => 0x0400, SYSTEM => 0x1000, DLL => 0x2000, UNIPROCESSOR_ONLY => 0x4000, BIG_ENDIAN_MACHINE => 0x8000, ); $data = {}; $string = "\0\0"; is_deeply($s->parse($string), $data, "FlagsEnum: Parse: Empty"); ok( $s->build($data) eq $string, "FlagsEnum: Build: Empty"); $data = {EXECUTABLE_IMAGE => 1, REMOVABLE_RUN_FROM_SWAP=>1}; $string = "\2\4"; is_deeply($s->parse($string), $data, "FlagsEnum: Parse: Pass"); ok( $s->build($data) eq $string, "FlagsEnum: Build: Pass"); $string = "PNG"; $s = Magic($string); ok( $s->build({ }) eq $string, "Magic: Build: Pass"); eval { $s->parse($string) }; ok( (not $@), "Magic: Parse: OK"); eval { $s->parse("PXNG") }; ok( $@, "Magic: Parse: Dies"); $s = ReversedBitStruct("foo", BitField("a", 3), Flag("b"), Byte("c"), ); $data = { a=>7, b=>0, c=>236 }; $string = pack "B*", "0111011100000011"; is_deeply($s->parse($string), $data, "ReversedBitStruct: Parse: correct"); ok( $s->build($data) eq $string, "ReversedBitStruct: Build: correct"); $s = ReversedBitStruct("foo", BitField("a", 3), Flag("b"), ReversedBitField("c", 8), ); $data = { a=>7, b=>0, c=>236 }; $string = pack "B*", "1100011100001110"; is_deeply($s->parse($string), $data, "ReversedBitStruct with ReversedBitField: Parse: correct"); ok( $s->build($data) eq $string, "ReversedBitStruct with ReversedBitField: Build: correct"); #print Dumper($data); done_testing();Data-ParseBinary-0.31~dfsg/t/bitmapx8.bmp0000755000000000000000000000215611057321770016774 0ustar rootrootBMn6(8ʦ @ ` @@ @@@`@@@@`` `@`````` @` @` @` @`@@ @@@`@@@@@ @ @ @@ `@ @ @ @ @@@@ @@@@@`@@@@@@@@@`@` @`@@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@ @` @ ` @@ @@@`@@@@`` `@`````` @` @` @` @` @` @ ` @@ @@@`@@@@`` `@`````` @` @` @`䐐Data-ParseBinary-0.31~dfsg/t/png2.png0000755000000000000000000010061611060173562016112 0ustar rootrootPNG  IHDR00WsBIT|d pHYs B4%tEXtSoftwareMacromedia Fireworks MX 2004vtEXtCreation Time06/05/04MqPprVWx[n0EiI5DRHn{wtTC( vܹ"_썽-[,g7/fw?[,[xlޭ[{}     _6I#')h^J9ݦAZݔ0#A\N$0dm80#`eq 07a 8iTW=qzJb| cl?7Rj4FC4H`Cw_|>܃~k|ţ< d0gN|cA]ԢH]^c~L\ t_ڵ(wS({#޾w0ɇοK2 ͯ|t_D?_4 گs}}mxX{d ҄s'V7{iKWpة\ƇWh|PՐlP|҇ۦd(]'y]*/XOg%mɠ^ƥGx&?_{/w:/vKcJ_?t~r :c)=?w_CC.c%?Kփs*8wn+^J<*s=3+\8      ?]ExgHmkBF)3,mkTSx}sǑײL$".BgW7 ( G()bMZW2Q3=$݄GV/ݍo^l9ËK`J''dn{pfy9mG%1^ oyvrr ~읿7M{?{Eo|߁/`}7rxhc|p3s?|pq)srtD'4}b7#p4s:wOC<;Ggptn[#;ȩg7pqV>HvrpY6l_`߬7ͮ3\7W[":O'Ĩ0FwF{+@b~h=sXaU` w -->t<| >W]qqI{>L'㑽hgsyL:A $|2mX(i;g<{?q޳ޯ[% >&sj%~&J,Ÿw)p`m^Bg59&sɷTv :*Ieb@b4ݴPQ,E jSĉ*[Bv苍bƲ땳5F~0lZt@c_V7lj,S@.m^Ok ~:m/RR[31mjlDS3Ro筐\s-' u|youKD%ð5ğV6͈$έ;/F3}W>[BmzFyۯ=VBg1l7VE[9thA~%[MlV (D2d!s J%xZڢ-Z.ed,e1-p4VƽGr$ƢYE+\EiQ"V [UdI'xI{J`N(aHf7fsXbFC=vGְrX43tUHE_ExUltzE{p7/'#a_@x$[9N/#y&=MA3 &$B4njL{d՗MHYEH]Ieߧm$z}_+ %0) 40k}Tn9G]S#L;uWM\6S&ņ6o ο5Ol>%D3VUk%F@ͤڸiő]$M3w]s9ZMձ'v5?HoɕHI=8H=mm ib-d`}C9lFyEml6T1-6e;p=plH@!vf7R62S.=N9_Y~=P.S.mfЩffZ#3|ZW^ZRNuyS 6qCp_'t1293o?-YPزO,p0F@:Ej[##m7yw> ő0 /ldz٬6V;לXb5rkqk`s>;,{v[X-*Ѽ7+Q۽؄Go7I2=d%DMTʷs\Sb@@Cza: a%Ʉ7 4ԕ箂$\WӮw5M{;%US@f zOQjW=S IgYoJ >gWIQ:(( qxP/.o kדN#9x~Ӫ^R##`q{ijd57Ns:7erj:f`7sS}Yr@;ZKmGnd{֚npV_An KƼ~1 (-p`^k覠#wR*ȵ&I Dh:GSo01.ez7.㑟W*˲n6Y*5 df*zL|1Lg)ܴ9G01Fy"+N`.llN\.Z#z<&lfz7L)E#@㳕p C+!uHځ_`=u$o/55߇o2.6ϟ,Fo/7p;Xe>ҿr.#yמ}5O_ؽ}G=Ac8}pjyx-Ō,ERz}^:l)ʵU==kwﲗQcxk<= -3p$Egz@W4|n%3oz{ Ψr祳}+lkҞ 9+ !]Ro9}N~ u~\qc;"݋ԛqWFUqU>"[0x#\t)qj _łWT(Xwէ/TǽKOågqV'[XާU¢R(T:%ئ:b [I>_~Ir>?)H8{IlR5ZX݁f!Jp$_Cw %_HjUr j xDZOz3QUWYhi7 Gt~QnqD'g ~ֳtU~H~(ݗW5wc=u:+w؈_"d*hzLzo.ıa}^bvp*> -h=@߽"݅ M#.WNGwK-'U9гgGݜitu򄬻U<'Qd;Wp|{B)}{lSnJVn=;dޝ8#K)#ҸmȝjW@n>YEz?SčX!rU@YU5[+߂=gߒTR ԍ|>׺ZmZo/{v_/ON=e+eUINw {t?vZޔFw`>M.L"\}JϺz'M9;mEUNs7%}+HΪcl sR5Rf=] G,)o;k#_%+]VJtY>+ O|"m/]tNr{@gMH;NW1)l%1uJC.q6uy~]en?^gU$>M-By]b_| xm1fplA:O5oo [;}JHn?(ܿl~jr?F~0󙀛9nɺ,\<,i-.(Ov} ggcy:c sȋS3jYYo ayUNn1sSim=bA}VsmHHpu/HfH ZӝHrw]0aUR 금$}g!)X?~; IuYd٥ H +qŢǿ αwܖ_^ٔWԯ"w7\Gm)n#F|5HoGNuνq_tF0]|WƉ/o;UwcJd"߷Ȥb~{Mu_g~Uӆlz.$K 4lN;)F Dz힨^}O.>?][}^[i *˅o3-rpk[Tqyy嚊?1<|4L  h3:-C:e8ӱ3 g퉯\IO;g_Ìyћ$uQ|T_zI0I lx>(0 |~rN9}(vdd7x7VV#|%llb?;.pyL%'4\-W &3L˃HnS/`C8\t==heyȬ (mI)8[>!+ CLRH)!yeHS6d1V)E'JHwō}T3F=@~t&F QN G IoPB >WpC"PS:QKId@&5 KҜ J,NFdTBNFh\h12BFF4( d6&0RtYNdx @ UI pHdi&[3LdI14 o-iHVDɰ:b}H4`ٔ D! Cu҄Lei[WTk" T[NCG$u*[L*$SVB- Tb M zb. slÖ=4]^<^Sux G ˔̴wK*Ճ. Q+? yJ$9}aꪈ~S\vPF27*Gd2-ؐ`Oi=wE&?7=@{oc~[yHL O 5:I & &"zyo/Roi xGFSITf?i(&u"n0{nil1HZ)U1<2j֖U*iRS7肄 ZoS([y+326iփ"S(І*U[p,3 )(-y b^rgU|JliߠsJlͅFn4 MXTh]]X|Tfz> RLU#4yJ~3CAhcA _t-_3G*nXR˾I}n:A+)Rz:\%Oϖ'0W> K]JNƝJC]X7bJԙF i2u; X2|*nF Py3ɃE2] 'R6u &$1FZ)m_ˆi5Hԅi "FVbbqF1&0;k$* 0(izHRCIĕA8K0)Cʩr`eT 7΃&jM"USh&9I=50D.NARR!,p߉Z|I4L11c2کSnɥSq!u)4U+캅e!Dlf4̋G Dݑ1Рʜ38)5ԂD0J8aYfM9#`GaN )a'N;0K@D:ђIʲ@I bK(WNkg(7OPeD,wHͫt2:`XE<Z Ki:9JpNE,1`xJsd9GP{vdhrnH%,."):ssTu!tQ h<< (xϺx@%1IET # h '*uZ6@&Ҥ4,K]B Szduf2WP$ExK#s*hMSE`IULdf jYDZi1HT"/ -p\gq2a7^L T"U"@:92n$3@Sh )ba;P`YbWˋcTsNAeqY@g gzX@Yvp ꐥ*(&H$`anaT! 2QD F5.q2$ SsLJ ^Gj>]&YuB BQktD1)Qg)P;E~ f3_Ѻ%\h宋0ݢ= Icf1w*l6NW$JξSxe+a,HAG8:T L,T5x'9 d6eiair}pOI2٪ SvVs:tSI-Yb̼ZjæUnpӳLvUbdYkVnEr?Y\ȝt20I5nn+očfdBQ,Ȃ)}KX0S_wj%+拪%p>SD Z: "LWe\% +[}2%n(Ar\`d檑8 7y @ЌXXW635VT /l716M0h.N!N^Sΰo9ڛ1/ y|5cj6ޚnPAW4\Q uKXM+XY@_(gꫛ kjXI6-uR$g3 @$ +J&2 sbk>YW ȴRy+`RXn܀=Pɬ/TKtlqD S:-|:LҥNl 0ʫb,McRCTu]=4~u75ejV^V, w== L4<55^. _',81BD\WJחJ)\hU W ܪ!.=]MDVñ4/,fpj8PьF`[4 3Sp&k@Twިph53,3{B /}Y4m`byXy$&M2:h*8P`!<1*AGc .WspE<Vvb$Bœna|{UW*,K9΋J [@uѩ1YbqX%-5%@YG"@,$fjGR5fwd*`ʛP[FoUܭq*bwy3L eY1i< ٟ6 GGx+@7)Y.[86xz^de(ʙ$MJY,A7RP:c~cA96>ů0qPEfPͥiz-Kx/[`0skgnUl'ŤpAleĢ;E[ˠҊ<₪qZQrT5<[Xg娸:O&7T)`Q &t}BXee*˼ojcYEK}` +`W| # JA#'P1&5UQZ+yyGT 8&XO*^ ʫ 2/ҲZ٪(/aYaPZ( 8\_ $@eIvQ|=ޞ#[wkDA%y#lephv%>eR Oe̶͆ŪrMڮBЖ\[f!g߷o/WWT}כ&7ܫ*k*}Me5+-o/Ж,zb_g[+8>Շ47÷xF`2M%x2o;N{"4[;MVyVޤ:_-{OhY-mkBSx]0{5|Q_V ؄&MfЃ{&;;ujh>u5z/LcFT яjVc{AZڔ^p u9ZҀ ن؛=ؓmOM6s[ YN\f_sgzUN wRm#%+% cVC~:LBL :\:m mkBTWx흍8 FSHI!)$FRHnw HYx3ꇤsaaaaxIǏ'U{o_ھgW9 o'GW {>~Jlo߾)*/N\ϱov[iZ_ձaJΝ/:6O- 92b?Tlk%?_21B sY5>:>c=1Ow y^- ڶ,XzusM#גU]>H_yYv!ۉ_mi Rus]Xm_g)YY)m]y,m z1aaaxEߓGקo/Y\k6xjgH|yu.\aæM&wk#ϐ$?]Mo\Ⱦ,/ڥQ@~6s?)}, l gX #vQg Bٙ^uのuhm?}{].~}v_J;xogJY]޳@.)oqC?}>@Xߘ'-(W? źvƔOʙRv[K?[A}?-wmՑ}g\=c}M ggg DŽ-B^k_g?F? v0||؎=ǧHPgs/hؑI t~{n^}ZyD5XWvO)"c0vY Z|~_%/,p\ɹyΰZ/;/xs_9?Pܯ5ݻ\[y|č8gʱL{? 0 0 _k3>z_\S |<)b|7aaaxn.ta?l^Cvkؽ#~e)3<3^kdlc&jK+o"e<.ʞ`^(3zu l+6v<ï k7]/lc[`On}򚄫 G뎱zt^v2)?;Wmr5ocIz?Ozx{&!ez."ѯ 1Gg{+ҏlw<=}GݽFƨ^)zIpG K֜{{e G12ۭqiumf>.}~a? 0 0 [u+7Svq֭y΅ ?ނ}XwŶv?ߩDZۓ-q/?߳=<~#>Fk"qzrQo 9r,nY[;o:)@-`ק-7({߯S@µK9֠ɸ>:n3 _[_*mtcmC>qSL=<6;ǫsaaa{xˌ\ފpx?0׋#5zяc]x^l򼠕(f:~٣^lin59W~\;?vn6erUbS~v^U O7O(|;+SG4|?f*?rW~2oNٟS9~daևmH6mX[J~s.ym4ٶO|Bd/b5ɿyU? 0 0 0 0 0 0 0.P~*1@G\⟿KrKXs2(ߥ纎J8'>X@▼QQbqwx b)_K|v 1M6kee-2Ǜ59?K^E~9ϱQﱮYF8N?~;:=J<-tĒyNAgC \NXKs)'^Kg\~2}6}Գ)n]Or^j~"{p29w6/.z-v:+M{WJYZ굢`% Ҥl9ힶկ#OUz+U?;sd~vND7*.Y+v:ye;8}~|+ÑޅN9}{Bƞ#txխsXɿkSV/uJ=o G<ջL'L:D]6jfgLz/+ؽ[{rCMYq~[{yy czA;w9zszWHVax3 %mkBTx흍) q ĉ8D^>׻gI@XjjgiЃ`0 `0 ?ϟ|:seQ3|ӧO|:2|.};7eGFO6_Qv]T]^ˮg{>pjzkuo{yye?{-x/ D:3D&򈼹e^Hyi#/OGzϪ߯_~ :sMe#M3Y#=2 QЙ[\s=E8}E>GȩT ڲTg-}VfoSVwzV}./>~!?U1<#}=F[ ~QڋBN..+푹^edLo+[\-k dW(}6q$#?z6Bөi?L7!3O_Q}Пuo[=tkȋM!'}/Ƈdr2_Cﲨ: `0 :8o=+8-4}۞cĥXdq{bUq©ήm!ƶg*ΪU\z[GA=^+ru{LV U?)V>ғ)x|Yҁgi\yi^cUo*= !TY?rfgWsʽVn*VX#=Fϫ+[F~yH\L~[O҇h5ݵTow|Sfӟ+);F;:x )/OS yUo2e)Ve3'wgGg=J^`0  ľu kU,Ksؑ5nY,bXw{ w&3QהNQev ]ƷgcH˞i{A3I8hwduwUIWq8I>+@pQşGcZ\ƪUߝ]/:3d;ɫ:gB9R|GW~w2;fzt|+i5nΟgZY|<1NyŬ|E7k?z/k><=Α}N΅>uWydʬdz `0 *\?W8GY:Dgcg< 2+'W6qn؟{ru"wU쏘~c#T?+y{Q,,^qF/Xv8.֩g3}ȸOP ~n%hUG4(_sn|W}Tg&x^c,Fѭ+ <#+}/Uw8BRh_|33!mr\7U9m({ѝpvew[xG]߱?g;,nҽow8]וb?OV=Z_#ve?vN_WrYLo;1g9pV^G~>[_vNOS3 `0Q[ veO\k^8֔v<Zbz\Opbn$~}oz3ј mK vU]^iNWA#x딫jt q :E= z%օq)CcYEqyRG-+u (K\hP'*^ء^q=m=y|Kvūe\rȊ4={W1;=ݷxp;o@>ȘT\Ԏ+C=*ɫ|GJOCW]x1.ﵠ9_Eб Vq)v(ʑ}[GwǺ{-oSdו_˞׃2;iT&w*w:g׭SOsj%Z[~_˯d֮+w]7 `0]kIu+eL]ւoA^;=GR?v쯱;<y o$N1紈=:ߥPVu< <&3KyC/4r)i=*/|Ύ^]QNН1qGw>ù{ ?Kv:A}E:_n+{u=rq͓̳]>>d}+|L01`0 leg:׺񶊝`W,3O?]\9P~[kOWiGc~)-<w.3q}'vuw$Vnv(r52S;Wk_Kϔ8B/hEՠ'9w?K;x:x<|@cϽVyc@ۖSw8Bq]=2lBe6V}eR( VeZT4ade2ޒ+nYBTqSߔ<[&=f[|szP)G}{Zׅ3n7jpWwftEw[ǽ;`l? `0 `0 `{~i`oLy>uoi\qK|}7Svu9G쯿c¾#>,jow{ՆݲL=mW2u_8دjo?kD߱mw>#}E:OۡO;y`$jwymkBT6x횉m0]HI!)$FR?6c>>~sm+vuՑνYu8uN?WP>1JsWiV_uKEϸ/rˆ_gKW]ױEYcl,[TYHT}xL#}A GV7^}>iҞ-i;}LJX&TP3T#ߨgJl e'=?͘ona|7>?ǐU%;/mN/IfQփz{G}?v✽3X~j{zTAO^ʰ>?sy|G)PU{ ..T}6ڳ-F`p]k߅~b  О$wݓٱ|sCoA+q3lOx@(0a+? T,_7s\Ϙ^Bl1)C+k(FyN"8dPC_9>O0&l4Im+nwGrŰ)/tihf ѸX>E)<,6s45zb?J\<OM%O#(76:= ӋYAƒH Ls6MXBcX&ǘJte. 3.je(??Lj=%wZizFTx$kP8Em jAOހ>~؆B9 ֤8UKCvjbL Cy ;mj P. DkwUE€3ܨ8xUJs\ɟ+;}sFQ(KIXݛƨ 1 +KdX];Jģcx$D׷X`i @l̏rnm$^9΄zBGϞQ=nfkDe; <a>,⢞jk0B[p($Ǡp4 nq`XƓ vϵ.xHnorJ5Hu뇗 f a[Z:>36[g RL؍?( &w.7C#~B{] UW 71jk~ecGrD.=K@WDZM0倐0\xvqNZ ># BE )&yA}t?B Ym(WIpɱ |2+\2 )l8tl@Z.Be񅋍RSƃm>dIl'N adĢG3%#)?$s _5=YBR#-k"qGP-e"f%֩-ϓ378M9ϊ,_*n;HEBƱcl~ ˝[/sagIE2,z1t:kLș壋G){7ond{@rP>kwk׽ #kXfyEAB9uM4P=_lgW؇N#_nGpp ,ZUu6ȓVӰ0EK7*|]{75F\ԶzQz! uH>upT٣o3P)[^6` -d&*=%fY<^ط`_6|h3ء>2 Pq7ώ ,NsjF=B` 큳CiU)R鐏@LҮǧmb<2FHRqùFXi䎲OmGA}:*u f:@ʫRH.66jcGOpO- 6HKJU:Jǃv,3DZEƮqq7p?ȌK%ȧ$;?Qr6pP7`a^=R_)m>D3#£ _' Iɭu͋C-Rne㯄ssL<ȭ/R)|Lt_1Lk=rr 4/gEr~PnB[\g[{gYvRW' {Fem1{ wL;7&$xc0 n&u@5sCCձm8Heft x{q(aтa?Q%l4ςxmWI׆GC1kQ3iJh,KRO`ʲ4)%b6B8\pe;u)ko)#WSncRx{[sXv195_0Kՙ7>Tp5ٴl3S"؝LX睫[5m Q="u}pϘ*xbՉ#iM+@Z! Ϯ~jYݬ$?5mtu] %@݅:4h8ۃtu3; ΑO1A/r R*5i&j#Y2:$Z(ad@>'z L뇶6Z8|`6"X1_z' F-я?X^ A:?1;h/KVB' vOnFS ƤQ{=kh7MwXQp\v͓O/. N3HKRlK"q^Wh1wt h@3e6N|I;y?8t[[! $,ήLe"z%IކAkRl!3u8ځy?_W)AbCO!rza5Sn֗#<43y6"R߃CQ&>[# BHǽ{vekOTlq(UH͵h ݔ8,@tՂL{p/*L"d_y k,4 G̖bD>,.ok"D;|7[.DCA#ilϟI֬Dq]+eE _-- ڰc^Lq1~CCC9gNH8BkhJ#Z-`VoMa 9r$պZ-hkh ?C$ ^tď9d(8P݅]ڶw[wl;dn׆oKd Hބ(DInI M_(5)6H/Y1 QRk,nXHʉ?>df&6^EJmt{CCc`0ʅv5x<\9Yc}106"״!֏9dl:' 1H"z'7QqɌ#KR./CVgQȬ\ `?d1yuM6Ƶ8ZX]8^pwQE &1frRKi$GݜЕh3'{;;~FK37ku<pdʎ+C RMzƏ7)nҀ lEGyl:̑IoBS%|ЕsTulebA}Aʹ10A{KʘӺtjdLI=r PRg_LbR Şl?␔)![Fo wi&k^CV(t@pW2{hxHGRn͉eCbxԉ6GQd27\ثdS=\Ff*0ۣOP5(rZߙxQZ>~GAeN-jY7Ҿn;n?ӹ"Px}/NW:݊&׾:x" ꭥу;R펔 c䛅љElmG§a= h¨BG_uYnZ쫭FYs U"zM&:Gnu.DX5Xn;}ԫ%XO?~2&Frjj8 yA*W I9/ub)Zl: s 85J>~iI3Yԕ;:#hELם[ROd^GA˩f~Y!En0~/A Km>^WYq"<цF*c:xw|͞w%ehRgd9̕v3v Dgh>>?3hYDkgC(ʹƒԕSԜ| 2Q94(?OGQ34 fccPopTYaW(>@tX4`LGٞpɄaŰl\[9c26U M6f,'C4i?W~psϠ?kAKrŵk@I|>^xs?\`,D̒5W^w DMXf_8<%|8_왉pP1Wlm߃f?4:́_Ԕv M;k:p_sj؎qw]$F}y ,b'N=o0, ~M YR46+!}@~ujctCP.Y(x׎z?70WXFܣo3z0c8RGg0 TU򄽻w"/4֏CQ`[{Ocn]+{{ N!33+5]qpj' r9FDȬ)~: 9Gmx2-?sraG"yvUpa;Ră A\& ?#n 0eed~oq嶭!!DzP^H)>oȑ.ļԶ=Hy7S-M ?8ycߧq|#5"2Б lm#UeΤVbM͘jAc7Z ]> 4gb s 2WRsKg6 's8qzTT[R[w)I95xWj #!nN+zPڔ KgTE,?{^RDݥ=Ru^zîc&D'i74SJߔ&HUG[crͦ<׿~4}څh;lpAZ%XZ;tQ?yk1+Ƴu6[ Dc4Ɯ*dB#!}e>samhG3c^8u9󼵕⸈߂UyB;f "Yi=D =4&|C3g]~WgjhSIXU"1A5Fr4{AljwTt6</N \Rta| i>T.Wo>>xϯY{緷m,J{gg}v~)]s!?wXGFl!7U|Cnfﳅ:.@mq%臔Ru?.:aBֺE#Gg'yXDuSWNJD)21ѵVagWPqȒ s?¶@g")s\T{f3go^w:^"{d#!φt},nyWFKv„X4|VB~,˘_&fjp/WԍwaO H 3I`u1ͤ+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_W|+_Wݚw)IDATx͙OhUǿ4b =JZkjATjAz$HK4lzzkXfuvü7ofvg6>ޛ~{og $O{URPdIuRZIiPd̡ݍ&P#` E&IZߥﭯG.8,RX$e׹/r(f (3a1f Jp1rdS(PϱpGS;xs^!@ DJ['ʓ9TB6[u ivm;,9 'uכC.-O^0>sE}6s<lUnPYh@?:ȒVHыUR&)2m.o|.! &Dtq|S-FHNv&|odžD9xr'Vc!aLݘU%eUT,{]GJ-u^j k( 3"|j 9'='m]ñ}mG/ wd6WdTc #iiOJcZC蟆0[V"J/J&07}+`vmNlRvT٘E f:Qs6 gʡ*v`2Y?0`} *džX)j:vu ,ƒὸ:@hwAYvk ZﴣEfJ\-8ۗ7E1' q>s̾_P(*}ma,U_ 2P$pTpp;|\*>,fU q&zO/): + `̆W ~F.^Vb3In vH!poNlvc+`&8NL/6Jqf6kjp=W)ͦG zQOK3 m6;8rhd4Fl-ڤ 1c+)T/8x=FwK3V|:3<-Aued|#5gY٨$cؘxuD KYqJ (<,Uז@ >b6׽ ( m@an\ZsPEm*uLre@T݆Ëo9wW'okFP?1G,ͤS#Vx*k[ rr)ӁS3 ؚ꽥 c!/Q f|߀iRU93mF ^TeP! :kCz[e+V-'7IENDB`Data-ParseBinary-0.31~dfsg/t/bitmapx4.bmp0000755000000000000000000000022211057321246016756 0ustar rootrootBMv(Data-ParseBinary-0.31~dfsg/t/bitmapx24.bmp0000755000000000000000000000024611057323416017047 0ustar rootrootBM6(p@@@@Data-ParseBinary-0.31~dfsg/t/netflowv5.pdu0000755000000000000000000000267011242271704017201 0ustar rootroot0Jy-k!iɕ Q  ILj  QIjºH LLL{{  JQ`  JQ`   J9005  JI445  I=44c5  IbF 7  IFpd7  >I `x= > I`x= HºQI P HºSI Q HºPI Q HºRI Q HºI Qº HI$Q ºQ HIP ºS HI$Q ºP HI$Q ºR HI$Q  iºJPPº iJPP iºJPPº iJPPº `JPրֈ 8º `JPրֈ 8-º `JPրֈ 8^º `JPրք 8]Data-ParseBinary-0.31~dfsg/t/wmf1.wmf0000755000000000000000000000231411062027542016115 0ustar rootrootƚ@1S [  -- @ !--'-- @ !j---- $:A:A--'--&8 {{{{{u}{u--'--$A92,% $ (-28>DKRX_fmsy %,29@GMTZ_dinruyxszm|f}_}X}R|KzDx>u8r2n-i(d$_ ZTMG@9----%A92,% $ (-28>DKRX_fmsy %,29@GMTZ_dinruyxszm|f}_}X}R|KzDx>u8r2n-i(d$_ ZTMG@9--'Data-ParseBinary-0.31~dfsg/t/png1.png0000755000000000000000000000613011060173550016102 0ustar rootrootPNG  IHDRd9^gAMA a IDATx^\݋]OyC ؇`2`HAB) ;K-Ab dPb4iIۘii#12ıXk}>ɹ>{~{}sp…5Xh[s#Jh!l:6 ;t;w,4[v&زjcDzxv}:^,s[T;SٕͣFyݜ P^FC v*kwFɵ+hI!a8Dqb,- z3tg0lLbUv@IC*_~\r-HTVtPBa;e0zyLj!,I# aɈ;Ngi/BnxIdr$q  fDZ%!4 7(AθPglBÂЪ̥H1{_h"- 銵5:Q,9?V]oֵl%dp(L і'R78r@p"yIWzUL,ĕ`lr ݝ1y MgH;_⳨c .d.z\PBc>+k¼{k$gQ ڢݭl{&nZ8٣r 'c)GvSu+L0wmn l *u9C z ٚ;yК+D&l}Ӷ'D+&l}Ӷ'D+&l}Ӷ'D+&l}Ӷ'D+ B~PC }m5nZOaKlSjA=EEFOFUh|MW 7,."!Y4~Mss~m}8cEE5OV: Z?!ÞO Tu>W@A/!'C i!dxBTp !tԇ07yMq/-®qJ!{g>Q(s\b۾@gBM=Zprw4I!#{!*!@1Aq6"£Nc`-"֖f$p3Q:9!|^OТ`6[OtBV=V5?x!/3G؋rw%&X/(~Ƀ*Qڄ~@NӥK~ӥ$d1C(qwFBɝMm TuS~0Pfkٺ-VAb_KPs?tԯX!Ja AMJ 6W%Y2^DQ4yhV(P1'-$ǏnD@dxD ȩ@+"䋈L>W [Q{O[U<=ܐuPBXJ/MBM!9k鿇wuIC/;DIY?ZTE ̍# ˠX'fK^*Drf/Z𥣂kG&+@pM lB. sАzo%?_Ѕp$oCUlHya+!Q RSiSfS/xg?C %z,5ԽPX5B!؆t%r%37r_$*h%*-DYFBb &yD$93dB_݁u†5_Z*iz ڶQ_63vg@¶LيKJ.^AZ~,KCh\X*9]`'yBrIRݵ㉩א[o2Tm8>(UrŤן}!{!\wTVR,)I-Sղ͗ S$JNhkM!,mUϛ1I %Z+]Sݭl 3Z Buwm}aɼ3l9}&;|2m*6͏!dcQ6X+1>!Xq(7 ]>43?#qc&!U7}u$43"~?HbU 7<Bm1`fҵ{"WXEz&<lvU?4~5҆!8@:E fK @"fh@~"jݮZ}%q;t  4!Deka/u;Wb37|蓺G*CYOvhh! jt.6BZa-BFwX b#[]-ws/IENDB`Data-ParseBinary-0.31~dfsg/t/bitmapx1.bmp0000755000000000000000000000013211057273002016747 0ustar rootrootBMZ>(x8Data-ParseBinary-0.31~dfsg/t/02streams.t0000755000000000000000000001226611057041472016546 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Data::Dumper; use Data::ParseBinary; use Test::More tests => 27; #use Test::More qw(no_plan); $| = 1; my ($data1, $data2); my $string; my $inner; my $s; my $stream1; my $stream2; $s = Struct("foo", UBInt8("a"), SLInt16("b") ); $string = "\x07\x00\x01"; $data1 = {a => 7, b => 256}; $stream1 = CreateStreamReader($string); is_deeply( $s->parse($stream1), $data1, "String Stream: Parse: Simple"); $stream1 = CreateStreamWriter(""); $s->build($data1, $stream1); ok( $stream1->Flush() eq $string, "String Stream: Build: Simple"); $s->build($data1, $stream1); ok( $stream1->Flush() eq $string.$string, "String Stream: Build: Twice"); $string = "\x07\x00\x01\x08\x00\x01"; $data1 = {a => 7, b => 256}; $data2 = {a => 8, b => 256}; $stream1 = CreateStreamReader($string); is_deeply( $s->parse($stream1), $data1, "String Stream: Parse: First of two"); is_deeply( $s->parse($stream1), $data2, "String Stream: Parse: Second of two"); $stream1 = CreateStreamWriter("\x07\x00\x01"); $data1 = {a => 8, b => 256}; $string = "\x07\x00\x01\x08\x00\x01"; $s->build($data1, $stream1); ok( $stream1->Flush() eq $string, "String Stream: Build: Continues"); $inner = "\x07\x00\x01"; $stream1 = CreateStreamWriter(StringRef=>\$inner); $data1 = {a => 8, b => 256}; $string = "\x07\x00\x01\x08\x00\x01"; $s->build($data1, $stream1); ok( $inner eq $string, "StringRef Stream: Build: Continues1"); ok( ${ $stream1->Flush() } eq $string, "StringRef Stream: Build: Continues2"); $inner = "\x07\x00\x01\x08\x00\x01"; $data1 = {a => 7, b => 256}; $data2 = {a => 8, b => 256}; $stream1 = CreateStreamReader(StringRef=>\$inner); is_deeply( $s->parse($stream1), $data1, "StringRef Stream: Parse: First of two"); is_deeply( $s->parse($stream1), $data2, "StringRef Stream: Parse: Second of two"); $stream2 = CreateStreamReader(StringRef=>\$inner); $stream1 = CreateStreamReader(StringBuffer => $stream2); is_deeply( $s->parse($stream1), $data1, "StringBuffer Stream: Parse: Start"); ok( $stream2->tell() == 3, "StringBuffer Stream: Parse: Step1"); is_deeply( $s->parse($stream1), $data2, "StringBuffer Stream: Parse: Step2"); ok( $stream2->tell() == 6, "StringBuffer Stream: Parse: End"); eval { $s->parse($stream1) }; ok( $@, "StringBuffer Stream: Parse: Dies"); $s = BitStruct("foo", Padding(1), Flag("myflag"), Padding(3), ); $inner = "\x40\0"; $stream1 = CreateStreamReader(StringRef => \$inner); $data1 = {myflag => 1}; $data2 = {myflag => 0}; is_deeply( $s->parse($stream1), $data1, "BitStruct over StringRef: Parse: First of two"); is_deeply( $s->parse($stream1), $data2, "BitStruct over StringRef: Parse: Second of two"); $inner = "\x42\0"; $stream1 = CreateStreamReader(Bit => StringRef => \$inner); $data1 = {myflag => 1}; $data2 = {myflag => 0}; is_deeply( $s->parse($stream1), $data1, "Continues BitStream: Parse: First of three"); is_deeply( $s->parse($stream1), $data1, "Continues BitStream: Parse: Second of three"); is_deeply( $s->parse($stream1), $data2, "Continues BitStream: Parse: Third of three"); $inner = "\x40\x40\0"; $stream1 = CreateStreamWriter(Bit => String => undef); $s->build($data1, $stream1); $s->build($data1, $stream1); $s->build($data2, $stream1); ok( $stream1->Flush() eq $inner, "Continues BitStream: Build: OK"); $inner = "\x42\0"; $stream1 = CreateStreamWriter(Wrap => Bit => String => undef); $s->build($data1, $stream1); $s->build($data1, $stream1); $s->build($data2, $stream1); ok( $stream1->Flush()->Flush() eq $inner, "Continues BitStream: Build: OK"); $s = Struct("foo", Pointer(sub { 4 }, Byte("data1")), # <-- data1 is at (absolute) position 4 Pointer(sub { 7 }, Byte("data2")), # <-- data2 is at (absolute) position 7 ); $data1 = {data1 => 1, data2=> 2}; $inner = "\x00\x00\x00\x00\x01\x00\x00\x02\0x01\0x01"; $stream2 = UnseekableReader->new($inner); $stream1 = CreateStreamReader(StringBuffer => $stream2); is_deeply( $s->parse($stream1), $data1, "StringBuffer: Parse: Pointer passed"); ok( $stream2->tell() == 8, "StringBuffer: Parse: Read the right amount"); $stream2 = UnseekableWriter->new(); $stream1 = CreateStreamWriter(StringBuffer => $stream2); $inner = "\x00\x00\x00\x00\x01\x00\x00\x02"; ok( $s->build($data1, $stream1) eq $inner, "StringBuffer: Build: passed"); open my $fh, ">", "t_file_stream.bin" or die "Can not open temp file to write"; binmode $fh; $stream1 = CreateStreamWriter(File => $fh); $s->build($data1, $stream1); close $fh; open $fh, "<", "t_file_stream.bin" or die "Can not open temp file to read"; binmode $fh; { local $/ = undef; my $content = <$fh>; ok($content eq $inner, "File: written OK"); } seek($fh, 0, 0); $stream1 = CreateStreamReader(File => $fh); is_deeply( $s->parse($stream1), $data1, "File: read OK"); close $fh; unlink "t_file_stream.bin"; #print Dumper($data1); package UnseekableReader; our @ISA; BEGIN { @ISA = qw{Data::ParseBinary::Stream::StringReader} } sub seek { die "UnseekableReader: seek should not be called" } package UnseekableWriter; our @ISA; BEGIN { @ISA = qw{Data::ParseBinary::Stream::StringWriter} } sub seek { die "UnseekableWriter: seek should not be called" } Data-ParseBinary-0.31~dfsg/t/05bigint.t0000755000000000000000000000364111250211464016337 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Data::Dumper; use Data::ParseBinary; use Math::BigInt; use Test::More tests => 16; #use Test::More qw(no_plan); $| = 1; my ($s, $data, $string); $s = SBInt64("BigOne"); $data = 1; $string = "\0\0\0\0\0\0\0\1"; is_deeply($s->parse($string), $data, "SBInt64: Parse: one"); ok( $s->build($data) eq $string, "SBInt64: Build: one"); $data = -256; $string = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\0"; is_deeply($s->parse($string), $data, "SBInt64: Parse: minus 256"); ok( $s->build($data) eq $string, "SBInt64: Build: minus 256"); $s = SLInt64("BigOne"); $data = 1; $string = "\1\0\0\0\0\0\0\0"; is_deeply($s->parse($string), $data, "SLInt64: Parse: one"); ok( $s->build($data) eq $string, "SLInt64: Build: one"); $data = -256; $string = "\0\xFF\xFF\xFF\xFF\xFF\xFF\xFF"; is_deeply($s->parse($string), $data, "SLInt64: Parse: minus 256"); ok( $s->build($data) eq $string, "SLInt64: Build: minus 256"); $s = UBInt64("BigOne"); $data = 1; $string = "\0\0\0\0\0\0\0\1"; is_deeply($s->parse($string), $data, "UBInt64: Parse: one"); ok( $s->build($data) eq $string, "UBInt64: Build: one"); $data = Math::BigInt->new("18446744073709551360"); $string = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\0"; is_deeply($s->parse($string), $data, "UBInt64: Parse: minus 256 (18446744073709551360)"); my $ans = $s->build($data); ok( $ans eq $string, "UBInt64: Build: minus 256 (got:".unpack("H*", $ans).")"); $s = ULInt64("BigOne"); $data = 1; $string = "\1\0\0\0\0\0\0\0"; is_deeply($s->parse($string), $data, "ULInt64: Parse: one"); ok( $s->build($data) eq $string, "ULInt64: Build: one"); $data = Math::BigInt->new("18446744073709551360"); $string = "\0\xFF\xFF\xFF\xFF\xFF\xFF\xFF"; is_deeply($s->parse($string), $data, "ULInt64: Parse: minus 256 (18446744073709551360)"); $ans = $s->build($data); ok( $ans eq $string, "ULInt64: Build: minus 256 (got:".unpack("H*", $ans).")"); Data-ParseBinary-0.31~dfsg/t/03lib.t0000755000000000000000000001165511242272052015634 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use FindBin; use Data::Dumper; use Data::ParseBinary; #use Data::ParseBinary::Graphics::EMF qw{$emf_parser}; use Data::ParseBinary::Graphics::PNG qw{$png_parser}; use Data::ParseBinary::Graphics::WMF qw{$wmf_parser}; use Data::ParseBinary::Graphics::BMP qw{$bmp_parser}; use Data::ParseBinary::Executable::PE32 qw{$pe32_parser}; use Data::ParseBinary::Executable::ELF32 qw{$elf32_parser}; use Data::ParseBinary::Data::Cap qw{$data_cap_parser}; use Data::ParseBinary::FileSystem::MBR qw{$mbr_parser}; use Data::ParseBinary::Data::Netflow qw($netflow_v5_parser); use Test::More tests => 27; #use Test::More qw(no_plan); $| = 1; my $mydir = $FindBin::Bin . "/"; Test_BMP_Format("bitmapx1.bmp", [map { [ split '', $_ ] } qw{11100 11110 01111 00111 00011 00001 00000}]); Test_BMP_Format("bitmapx4.bmp", [map { [ split '\\.', $_ ] } qw{15.15.15.10.10 15.15.15.15.10 9.15.15.15.15 9.9.15.15.15 9.9.9.15.15 9.9.9.9.15 9.9.9.9.9}]); Test_BMP_Format("bitmapx8.bmp", [map { [ split '\\.', $_ ] } qw{228.228.228.144.144 228.228.228.228.144 251.228.228.228.228 251.251.228.228.228 251.251.251.228.228 251.251.251.251.228 251.251.251.251.251}]); my %dict = (1 => [192, 128, 128], 2 => [128, 64, 0], 3 => [0, 255, 255], 4 => [159, 162, 64]); Test_BMP_Format("bitmapx24.bmp", [map { [ map $dict{$_}, split '\\.', $_ ] } qw{1.1.1.2.2 1.1.1.1.2 3.1.1.1.1 3.3.1.1.1 3.3.3.1.1 3.3.3.3.1 4.3.3.3.3}]); Test_Netflow_Format("netflowv5.pdu", 5, 30, '10.13.16.81'); #test_parse_build($emf_parser, "emf1.emf"); test_parse_build($png_parser, "png1.png"); #test_parse_build($png_parser, "png2.png"); test_parse_build($wmf_parser, "wmf1.wmf"); test_parse_only($pe32_parser, "notepad.exe"); test_parse_only($pe32_parser, "sqlite3.dll"); test_parse_build($elf32_parser, "_ctypes_test.so"); test_parse_build($data_cap_parser, "cap2.cap"); Test_Netflow_Format("netflowv5.pdu", 5, 30, '10.13.16.81'); test_parse_build($netflow_v5_parser, "netflowv5.pdu"); my $packed = "33C08ED0BC007CFB5007501FFCBE1B7CBF1B065057B9E501F3A4CBBDBE07B104386E00". "7C09751383C510E2F4CD188BF583C610497419382C74F6A0B507B4078BF0AC3C0074FC". "BB0700B40ECD10EBF2884E10E84600732AFE4610807E040B740B807E040C7405A0B607". "75D2804602068346080683560A00E821007305A0B607EBBC813EFE7D55AA740B807E10". "0074C8A0B707EBA98BFC1E578BF5CBBF05008A5600B408CD1372238AC1243F988ADE8A". "FC43F7E38BD186D6B106D2EE42F7E239560A77237205394608731CB80102BB007C8B4E". "028B5600CD1373514F744E32E48A5600CD13EBE48A560060BBAA55B441CD13723681FB". "55AA7530F6C101742B61606A006A00FF760AFF76086A0068007C6A016A10B4428BF4CD". "136161730E4F740B32E48A5600CD13EBD661F9C3496E76616C69642070617274697469". "6F6E207461626C65004572726F72206C6F6164696E67206F7065726174696E67207379". "7374656D004D697373696E67206F7065726174696E672073797374656D000000000000". "0000000000000000000000000000000000000000000000000000000000000000000000". "00000000000000000000000000000000002C4463B7BDB7BD00008001010007FEFFFF3F". "000000371671020000C1FF0FFEFFFF761671028A8FDF06000000000000000000000000". "000000000000000000000000000000000000000055AA"; my $string = pack "H*", $packed; ok( $string eq $mbr_parser->build($mbr_parser->parse($string)), "FileSystem-MBR: re-build"); sub test_parse_build { my ($parser, $filename) = @_; my $data = test_parse_only($parser, $filename); ok( copmare_scalar_file($parser, $data, $filename), "Built $filename"); } sub test_parse_only { my ($parser, $filename) = @_; open my $fh2, "<", $mydir . $filename or die "can not open $filename"; binmode $fh2; my $data = $parser->parse(CreateStreamReader(File => $fh2)); ok( 1, "Parsed $filename"); return $data; } sub Test_BMP_Format { my ($filename, $expected_pixels) = @_; open my $fh2, "<", $mydir . $filename or die "can not open $filename"; binmode $fh2; my $data = $bmp_parser->parse(CreateStreamReader(File => $fh2)); is_deeply($data->{pixels}, $expected_pixels, "$filename: Parse: OK"); ok( copmare_scalar_file($bmp_parser, $data, $filename), "$filename: Build: OK"); } sub Test_Netflow_Format { my ($filename, $expected_version, $expected_frecords, $ip) = @_; open my $fh2, "<", $mydir . $filename or die "can not open $filename"; binmode $fh2; my $data = $netflow_v5_parser->parse(CreateStreamReader(File => $fh2)); is_deeply($data->{version}, $expected_version, "$filename: Parse Version: OK"); is_deeply($data->{count}, $expected_frecords, "$filename: Parse Count: OK"); is_deeply(sprintf($data->{nfv5_record}[0]{src_addr}), $ip, "$filename: Parse src address: OK"); } sub copmare_scalar_file { my ($s, $data, $filename) = @_; my $content = $s->build($data); open my $cf, "<", $mydir . $filename or die "can not open $filename"; binmode $cf; local $/ = undef; my $content2 = <$cf>; close $cf; return $content eq $content2; } Data-ParseBinary-0.31~dfsg/t/cap2.cap0000755000000000000000000003524411065530162016052 0ustar rootroot xERJP€B` E< VP€B` E0 @%6< MP2p@ xE>>B` P€E0<<P M Ƞ2p{p xEe6P€B` E( @%=< MP2 ȡPA@} xECiP€B` E[ @# < MP2 ȡPA@ qGET /home/0,7340,L-8,00.html HTTP/1.1 Host: www.ynet.co.il User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.1.1) Gecko/20061204 Firefox/2.0.0.1 Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 Accept-Language: en-us,en;q=0.5 Accept-Encoding: gzip,deflate Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7 Keep-Alive: 300 Connection: keep-alive Cookie: vgnvisitor=rB1PM0003Eg000LUhdUHvW07~5; History_URL=/yaan/0,7340,L-24635,00.html; Client_Geo=IL; huge_heb3_ad=on; deadlocks=X xEW6B` P€E(B<<P M ȡ3Pd; xEZ B` P€EC<i<P M ȡ3PdHTTP/1.0 200 OK Server: Microsoft-IIS/5.0 Content-Type: text/html Set-Cookie: deadlocks=XX; expires=Tue, 09 Jan 2007 20:08:59 GMT; path=/;domain=www.ynet.co.il; Set-Cookie: deadlocks=X ;expires=Tue, 09 Jan 2007 20:08:59 GMT; path=/;domain=www.ynet.co.il; Vary: Accept-Encoding Content-Encoding: gzip Cache-Control: max-age=1200 Date: Fri, 05 Jan 2007 16:08:59 GMT Content-Length: 20825 Connection: keep-alive iWI(֪^lj.< 0`]uu+Ȳtz? ئq Q.Traǎ{ɿDGsfZ1-Z^jJh|2E\U3"|02->wx;!.O\Ǘ*=-x+=7~z _3wMh`<_*^ >=6xy{|] b'T|dU݃z6N.-Njfb8a]rҪwM{X-RkMc0Lc_8"TT':TdgP @OeB/0DDIT CE^ڪMXƺaY5aӇc2,RnLl- yhl(r Fp)tR$s]6Z3ck.mG@mViE1,mhTcN/JG1m8.zm &d1&4td8:ѾLWZyIqα\׫aEjX]T'<ϊL4֚< 5e*XrqLWJH-52Tlb&~TOm6'_ /)~]_ Z%f3 &0U &`p)PDbBˌY2ٸ:@SiXfuPa77TUC-8,Ks PrXќKMS ŸH =]_YbRFٟŝ{3.z~ݕKgWG7_ۙeFHk`)!ZĪ2ς,khىKT`y ~r2HPBɲDbU7kzܨK)E'+w氨^^iGQ,»` ߭mꕺe^e gpV c%~z33359 xEu 6P€B` E( @%;< MP3 ӁPA@p xEy B` P€EE<g<P M Ӂ3Pdf1X^)*1@7u: &-UfTj_/U˸ *#6Mh`wdg@[OcIGXB Z9S 9ċEIgض`̬խ26jylYSjz4Q.B5Oj"V(ƚYFcaa`2k $Jh Ѫ/Rd.hd2iq5<^1k[**kNJ`?8o;VUF6z౻_ɇNۈfhwAB\Ԉg2W$G'U^$$Hqȥ; ChxOg}nq NsX,mV1b#;3YC}ՠ}v jgL&9I1 c vs:H "Y>: 4Hf3LryUL:"?np{Ad:<a-HO_û˷#+%X" -nRO˾IZ.?¿#6RϤOd|#4ٽr[ܮm+w%ۃW{bx†#PwSow& ?!cS|K4}BC8A3-;~->9h?N}D#C"cv#<{̫@Nk Yu-^)X##H,gnd>]LkROJ .@\zTvel8;z5Rjht(_[o}b ]‰/VK/m=T xfOMVƏh,T*fq([<8jrX0-fXc }07ґFD;#vTvuf;6))!(uhk}2zK`-[C#\w^9cj$tyUȋ%͠[6{,^{#;s=>C VyT r"ruBZڤAZb@kߪDvz#d] + >JQ?꣉ 8'NX2lC6m`X"Ӗ7 +6SW cRwbZ$O#RPܟYO5Z 2Y.5/Mcӳ2σtLeLVյup" [+D&~,\y&.HBίOr5e_^H%'| iV]mU龒8jPuUV -d<ϩxR!;p8؀m Xݬ[ONֽRaJx4zz#!#J-떡Î#vbD"JuBU#j$FZBOW?(8Ч^ֽ=-ֆ`=ZeRlPKP0M xE 6P€B` E( @%:< MP3 aPA@e xE* B` P€EG<e<P M a3PdCm1-^-"܇b\a&L$ѢW 8N"ޣd<f82kbLDz r?R{#L&2Cm1I-fzj{Yl/ew I7Q>pm dQdU,pJ jJ/)tt2(1@pT % S >g_e^e)s.G.qͱT%Q*oQfYvipivnz;c/CSHe1 %u'ty _[-ep% WƁ;n vH#d.ԸO@Eq59j,J-Xk[,R <_R-g[^3+~K&Ve[t$ۃM".D!w7tەaYoQDT9`j9mԧuޖ70wQLQ2vԟAe˪q}+fX)guiSƺZ̳pH&}ԛy__<z֒dlͳyn8*!ڗqqiW<\4vpق2ZfjAYv2qC igT LB8"zoye_>\\Dy@ -\^hC)DF:\b21_c)V8"fʞeX42Ws3W.*l'0X||{_)&*)f/<6.x1>xP+g>/ Sx@ ăa;4,sh%3Fn\-߄vkOߝgnGWdx]U2 XɿOA"βQ>I+{iT-:K2>\zz&5dXm yDdVQ!Ņi2a?@Ro,O_P .廗l7.$3q۴Im֍u65{ݐM<=Nc6/SU~9Br[p~Nne}_[F[?!;ϾGِhB!qiDF07x z6ڭu^-`CS7V9F={V9qkrKNcKA9 xE B` P€EH<d<P M њ3Pdj9#]?Wt90.{u:;to]}t=sȮ+uOArnͪ@9`j:] Nݹσr['̪DRFR+m5[]( V,pkjm;k+v0˳ӾLzf rmt0S>TzTS)Mԉ!-QB  ׊^v~,\p<fvKΥ=.}t~W8Cp@9q3zm~V`f޹!@LSW9Olg8(' f5=(Pg]A= SH[|u(|gkP$4D_,3 d3vc[u]%9x=E9!mħu,L/tU|T z,s6K)“ [Z7/x}S9S/ӭ_ŢO]ߥQE)~ ?e\{.bz$1/$վT6hq\JԣORǁPٳW6)@F^k xեc< >rd|bOtoN7~gSt}6R$ҽ>zեd&t{kR V]wT\ brQx1?@  :x`C %`:El<֫Mcʇ!ۙڀy!`v6R$DslY?gt'w 4hScpt"lXpUv/Ŝ!3 ]DJΚP^2ҝvH&]0cf퉄gNxө6=f q-;vE?߬%:Y>ѳ{TPsLBwP]^A}Dc=i.fsO2WN71bޑ,1\Ǯ}5<5k CYFe: ĩ nw8٦,nD" rm\#kx ;^%Q㩶$ ۛ`SpԔV1-Idtf8>Y>rJ*1)e@a]A`{emyTGIR+Ahؗ i(>{!%ÓSkJs~حD[dAzG\bh[A ϛ4DHvΜ=ES-O#RtB :bSNOh)aJZ JCz=s6ApC򲞴Jfz 홰:%G?_$RPɋ'O&iX'6C> -ݛ%.%/y GnQ= IXmg>VaZk_u;/ÿ)o5Ǡ-hq6z*_pJQ6D$}CKg;Tb*x/X|4@h =e} bX~pQ`-s)qK~`w z$᮴Or<@x΀_vqc?9!"BMMڄaWQw5lOu2EHr Θm4%+s e=MM~ӽGa&ad~>P Px:U %cfm.ߠ隆4}|^h%I| h=W+2/l<;fA^HjϏ_6Srtt.>A/qx^dn3𸵫ϻ1WEJ$DJq\K"6ߗ\e!z%x,? ђG+{/oORn)SK˞x7g~NtZ'? &2雀)9nOTݎa 0gшc#O]OV[ .}'TZHb2z)Yq?} $ßuiVSͫ/"{˃'$8-NqL'cX:!kO&߳_J{%Dv3A*(ƼGBO1ah2HUs ]->Ӗ~~;>9!қێ/}")1Ʈ`fwop/wCƺrCz7LbFQTb:nhFzDpNiIMܺ (=v$oAܒ_._4ЇFL2, Ay+hva@I܆O &-`p_~R=N= 3wDtܽdWGt9H'U6(e=S@ NX2ڝ^C{^}!ߓpf'd~YO/%djs &jW䧹&a9z+ { $R8,5u@=sڏm7NdXb͔j4ģ12[xzV[\E 7*: :=&ӥ|so97Td79wWzJϱ{6^ i+r93}{ݜWˈmx ˓g^y$gr^p gll%CZH}'tקIf)}d&\>{ xE_ 6P€B` E( @%8< MP3 !PA@O xE"8 B` P€EK<a<P M !3PdUx })0314A={čAly Hw =krKIsmiTRZŦS##ȈTW:o;>)b@bY9[XSMR= T_Psw+& W̟73j39Y& L㝙[XX~4=3xO=廀֭VWw8ˣq,(αJPM p1D(?5C*A>o6V3HRl5cZXPX"XHá⺡™x62,:[.ryDHI୭B9kPDQIEQ{BGzV^ҩjaxA0WVT* GƷM ύlgxqyk'w@k8/ءy2.7FCHFK(t{{9#NEL=cѣ3`jo61l㧄#U4k? ǁo[S] ~K紛!E<󉷕3~K0[18ɜ7FQ̮.gN> 2n6# /RF .{doy^mΑd,NS96~#ox:[T_K\(DLI-`v1fƈc[9ޓhu%)ZH!?crfW, c6?"TήC)͈f_&3R:3Dvw]>O79^f#Ǽ?;,.z]w!z-qCZw)uA8B>˞n4BX&;Qؼ'zI_""$#}2ߗq,&vV*s с w(?'w xEN >P€B` E0 @%'< NPJp@Data-ParseBinary-0.31~dfsg/t/emf1.emf0000755000000000000000000000731411057326700016060 0ustar rootrootlc(J EMFuT 0F, EMF+@``F\PEMF+"@ @ $@ !@ 0@?@ F(GDICFXLEMF+*@$?? @$oD4D!b $$=='% % Ld<-!??% % $$AA" FEMF+@ FGDICF(GDIC/FGDICF(GDICGyFGDICF(GDICB<FXLEMF+*@$?? @$"CUPCCB( !b $$=='% % Ld@9  !??% % $$AAFEMF+@<0V?A@<0"CUPC"CUUCUCUUCUCUPC@: $$==_888 % % V,MG     % % $$AA( : " FEMF+@ FGDICF(GDICF EMF+*@$??@^?AXVUU@ A?`@, C*CUվCVUXC@( !b $$==_888% '%  ; 6 X4      6 X4      =M Y$~ =<? % % $$AA( " FEMF+@ FGDICF(GDICFEMF+*@$??@ U՜CjC CjCuCCuCVuCuCBC CCU՜CCCCUվCBCUվCVuCUվCCCjCU՜CjC@( !b $$=='%  ;UP F:FS-SS:-FF<>~ % $$AAF`TEMF+@@4^?A@$$==_888% % UP F:FS-SS:-FF% % $$AA( " FEMF+@ FGDICF4(EMF+*@$??!b Ld)??" FEMF+@ Data-ParseBinary-0.31~dfsg/README0000755000000000000000000000076411064251202015146 0ustar rootrootData::ParseBinary version ========================= This module is a Perl port for PyConstructs 2 See http://construct.wikispaces.com/ for the original package INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES None. COPYRIGHT AND LICENCE Copyright (C) 2008 by Shmuel Fomberg This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Data-ParseBinary-0.31~dfsg/Changes0000755000000000000000000000500311476440230015560 0ustar rootrootRevision history for Perl extension Data::ParseBinary. 0.29 Dec 4, 2010 - Documentation fixes 0.26 Sep 19, 2010 - Fixed a bug in Data::ParseBinary::FileSystem::MBR (thanks paul) 0.25 Aug 25, 2009 - Completed unit tests for all int 64 numbers - Bugfix: CString now respects its name (thanks Niobos) 0.24 Aug 17, 2009 - Fixes to the Netflow library - Fixes to big (64) integers - L/BFloat64 still defective 0.23 July 30, 2009 - Started work on big-integers constructs. (64 bit) - Now dependes on Math::BigInt - Fixed bug in signed int 32 - Added Data::Netflow to the library (thanks Andrej) (released on the jawish fest - Tisha Be'av - again...) 0.22 July 26, 2009 - Fixed the name of ReversedBitStream - Cleanup: now everyone are using $parser->runCodeRef 0.21 July 19, 2009 - Added ReversedBitStruct and ReversedBitField 0.20 January 31, 2009 - Strings now support encoding - Added the Char construct 0.13 January 5, 2009 - Documentation - Anchor is now a Value 0.12 December 28, 2008 - Documentation - Peek now is a NOP on build - Peek can now Peek Far (not zero) - BitStream now tell but can not seek 0.11 December 11, 2008 - Completing the design changes - Depricated Ranges, Optional and Select - Improve error report 0.10 December 4, 2008 - Design changes - Changed the way Enum default value was defined - Library parsers get their own independant module 0.07 September 21, 2008 - Add Library modules: FileSystem-MBR - Fixed test filename: NOTEPAD.EXE -> notepad.exe - Shortened the cap2.cap to 15kb. - Fixed FlagsEnum 0.06 September 17, 2008 - Add Library modules: Executable-PE32, Executable-ELF32, Data-TermCapture - Add $Data::ParseBinary::print_debug_info - Add Adapters: FlagsEnum 0.05 September 11, 2008 - Add Constructs: RoughUnion, Aligned, Restream, Bitwise, Magic, Select, Optional - Add the Library function - Add Library modules: Graphics: BMP, EMF, PNG, WMF. - Add Adapters: ExtractingAdapter, IndexingAdapter (released after my first child's birth) 0.04 August 13, 2008 - Worked on the Streams - Created File Stream - Revisied Flush operation 0.03 August 10, 2008 - Worked on the streams (string, stringref, warp, bit) - Created StringBuffer - Added 02streams.t (released on the jawish fest - Tisha Be'av) 0.02 July 22, 2008 - A lot of bug fixes, especially in the build op. 0.01 July 12, 2008 - original version; created by Shmuel Fomberg. Data-ParseBinary-0.31~dfsg/lib/0000755000000000000000000000000011535704017015034 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/0000755000000000000000000000000011535704017015705 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary.pm0000755000000000000000000015157311535703757020513 0ustar rootrootpackage 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__ =head1 NAME Data::ParseBinary - Yet Another parser for binary structures =head1 SYNOPSIS $s = Struct("Construct", Struct("Header", Magic("MZ"), Byte("Version"), UBInt32("Expire Date"), Enum(UBInt32("Data Type"), Array => 0, String => 1, Various => 2, ), Byte("Have Extended Header"), If ( sub { $_->ctx->{"Have Extended Header"} }, CString("Author") ), ), Switch("data", sub { $_->ctx->{Header}->{"Data Type"} }, { Array => Array(4, SBInt32("Signed Int 32")), String => PascalString("Name"), Various => Struct("Various data", NoneOf(Byte("value"), [4, 9]), Padding(1), # byte BitStruct("Mini Values", Flag("done"), Nibble("Short"), Padding(1), #bit SBInt16("something"), ), ), } ), ); my $data = $s->parse("MZabcde\0\0\0\1\1semuel\0\x05fghij"); # $data contains: # { # 'Header' => # { # 'Version' => 97, # 'Expire Date' => 1650680933 # 'Data Type' => 'String', # 'Have Extended Header' => 1, # 'Author' => 'semuel', # } # 'data' => 'fghij', # } =head1 DESCRIPTION This module is a Perl Port for PyConstructs http://construct.wikispaces.com/ This module enables writing declarations for simple and complex binary structures, parsing binary to hash/array data structure, and building binary data from hash/array data structure. =head1 Reference Code =head2 Struct $s = Struct("foo", UBInt8("a"), UBInt16("b"), Struct("bar", UBInt8("a"), UBInt16("b"), ) ); $data = $s->parse("ABBabb"); # $data is { a => 65, b => 16962, bar => { a => 97, b => 25186 } } This is the main building block of the module - the struct. Whenever there is the need to bind a few varibles together, use Struct. Many constructs receive only one sub-construct as parameter, (for example, all the conditional constructs) so use Struct. =head2 Primitives =head3 Byte-Primitives But this Struct is just an empy shell. we need to fill it with data types. So here is a list of primitive elements: Byte, UBInt8, ULInt8 (All three are aliases to the same things) SBInt8, SLInt8 UBInt16 ULInt16 SBInt16 SLInt16 UBInt32 ULInt32 SBInt32 SLInt32 BFloat32 LFloat32 UBInt64 ULInt64 SBInt64 SLInt64 BFloat64 LFloat64 S - Signed, U - Unsigned, L - Little endian, B - Big Endian Samples: UBInt16("foo")->parse("\x01\x02") == 258 ULInt16("foo")->parse("\x01\x02") == 513 UBInt16("foo")->build(31337) eq 'zi' SBInt16("foo")->build(-31337) eq "\x85\x97" SLInt16("foo")->build(-31337) eq "\x97\x85" And of course, see Struct above to how bundle a few primitives together. Be aware that the Float data type is not portable between platforms. So it is advisable not to use it when there is an alternative. =head3 Bit-Primitives Flag, Bit (1 bit) Nibble (4 bits) Octet (8 bits, equal to "Byte") BitField (variable length) These primitive are bit-wide. however, unless using BitStruct, they take a whole byte from the input stream. Take for example this struct: $s = Struct("bits", Flag("a"), Nibble("b"), ); $data = $s->parse("\x25\x27"); # data is { a => 1, b => 7 } "\x25\x27" is 0010010100100111 in binary. The Flag is first, and it takes one byte from the stream (00100101) use the last bit (1) and discard the rest. After it comes the Mibble, that takes a byte too, (00100111) use the last four bits (0111) and discard the rest. If you need these bits to be packed tight together, see BitStruct. Examples for the rest of the bit constructs: $s = Struct("bits", Octet("a"), BitField("b", 5), ); $data = $s->parse("\x25\x27"); # data is { a => 37, b => 7 } =head2 Meta-Constructs Life isn't always simple. If you only have a rigid structure with constance types, then you can use other modules, that are far simplier. hack, use pack/unpack. So if you have more complicate requirements, welcome to the meta-constructs. Basically, you pass a code ref to the meta-construct, which will be used while parsing and building. For every data that the code ref needs, the $_ variable is loaded with all the data that you need. $_->ctx is equal to $_->ctx(0), that returns hash-ref containing all the data that the current struct parsed. Is you want to go another level up, just request $_->ctx(1). Also avialble are $_->obj, when need to inspect the current object, (see RepeatUntil) and $_->stream, which gives the current stream. (mostly used as $_->stream->tell to get the current location) As a rule, everywhere a code-ref is used, a simple number can be used too. If it doesn't - it's a bug. please report it. =head2 Meta-Primitives =head3 Field (Bytes) The first on is the field. a Field is a chunk of bytes, with variable length: $s = Struct("foo", Byte("length"), Field("data", sub { $_->ctx->{length} }), ); (it can be also in constent length, by replacing the code section with, for example, 4) So we have struct, that the first byte is the length of the field, and after that the field itself. An example: $data = $s->parse("\x03ABC"); # $data is {length => 3, data => "ABC"} $data = $s->parse("\x04ABCD"); # $data is {length => 4, data => "ABCD"} And so on. Field is also called Bytes. =head3 Value A calculated value - not in the stream. It is calculated on both parse and build. $s = Struct("foo", UBInt8("width"), UBInt8("height"), Value("total_pixels", sub { $_->ctx->{width} * $_->ctx->{height}}), ); =head3 Alias Copies "a" to "b". $s = Struct("foo", Byte("a"), Alias("b", "a"), ); $data = $s->parse("\x25"); # $data is { a => 37, b => 37 } =head2 Conditionals =head3 If / IfThenElse Basic branching: $s = Struct("foo", Flag("has_options"), If(sub { $_->ctx->{has_options} }, Bytes("options", 5) ) ); The If statment takes it's name from the contained construct, and return undef of the condition is not met. $s = Struct("foo", Flag("long_options"), IfThenElse("options", sub { $_->ctx->{long_options} }, Bytes("Long Options", 5), Bytes("Short Options", 3), ), ); The IfThenElse discard the name of the contained consturct, and use its own. =head3 Switch Multi branching. Can operate on numbers or strings. In the first example used with Enum to convert a value to string. The Switch discard the name of the contained consturcts, and use its own. return undef if $DefaultPass is used. $s = Struct("foo", Enum(Byte("type"), INT1 => 1, INT2 => 2, INT4 => 3, STRING => 4, ), Switch("data", sub { $_->ctx->{type} }, { INT1 => UBInt8("spam"), INT2 => UBInt16("spam"), INT4 => UBInt32("spam"), STRING => String("spam", 6), } ) ); $data = $s->parse("\x01\x12"); # $data is {type => "INT1", data => 18} $data = $s->parse("\x02\x12\x34"); # $data is {type => "INT2", data => 4660} $data = $s->parse("\x04abcdef"); # $data is {type => "STRING", data => 'abcdef'} And so on. Switch also have a default option: $s = Struct("foo", Byte("type"), Switch("data", sub { $_->ctx->{type} }, { 1 => UBInt8("spam"), 2 => UBInt16("spam"), }, default => UBInt8("spam") ) ); And can use $DefaultPass that make it to no-op. $s = Struct("foo", Byte("type"), Switch("data", sub { $_->ctx->{type} }, { 1 => UBInt8("spam"), 2 => UBInt16("spam"), }, default => $DefaultPass, ) ); $data = $s->parse("\x01\x27"); # $data is { type => 1, data => 37 } $DefaultPass is valid also as one of the options: $s = Struct("foo", Byte("type"), Switch("data", sub { $_->ctx->{type} }, { 1 => $DefaultPass, 2 => UBInt16("spam"), }, default => UBInt8("spam"), ) ); $data = $s->parse("\x01\x27"); # $data is { type => 1, data => undef } =head2 Loops =head3 Array Array, as any meta construct, and have constant length or variable lenght. # This is an Array of four bytes $s = Array(4, UBInt8("foo")); $data = $s->parse("\x01\x02\x03\x04"); # $data is [1, 2, 3, 4] # Array with variable length $s = Struct("foo", Byte("length"), Array(sub { $_->ctx->{length}}, UBInt16("data")), ); $data = $s->parse("\x03\x00\x01\x00\x02\x00\x03"); # $data is {length => 3, data => [1, 2, 3]} =head3 RepeatUntil RepeatUntil gets for every round to inspect data on $_->obj: $s = RepeatUntil(sub {$_->obj eq "\x00"}, Field("data", 1)); $data = $s->parse("abcdef\x00this is another string"); # $data is [qw{a b c d e f}, "\0"] =head2 Adapters Adapters are constructs that transform the data that they work on. It wraps some underlining structure, and present the data in a new, easier to use, way. There are some built-in adapters for general use, but it is easy to write one of your own. This is actually the easiest way to extend the framework. For creating an adapter, the class should inherent from the Data::ParseBinary::Adapter class. For example, we will take the IP address. An IP address can be viewed as four bytes, or one unsigned long integer, but humans like to see it as dotted numbers. ("1.2.3.4") Here is how I would have done it. First, I'll write an adapter class: package IpAddressAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _encode { my ($self, $tvalue) = @_; return [split '\.', $tvalue]; } sub _decode { my ($self, $value) = @_; return join '.', @$value; } This adapter transforms dotted IP address ("1.2.3.4") to four numbers. Each number size is "byte", so we will use an array of four bytes. For actually creating one we should write: my $ipAdapter = IpAddressAdapter->create(Array(4, Byte("foo"))); (An adapter inherits its name from the underlying data construct) Or we can create a little function: sub IpAddressAdapterFunc { my $name = shift; IpAddressAdapter->create(Array(4, Byte($name))); } And then: IpAddressAdapterFunc("foo")->parse("\x01\x02\x03\x04"); # will return "1.2.3.4" On additional note, it is possible to declare an "init" sub inside IpAddressAdapter, that will receive any extra parameter that "create" recieved. =head3 Enum One of the built-in Adapters is Enum: $s = Enum(Byte("protocol"), TCP => 6, UDP => 17, ); $s->parse("\x06") # return 'TCP' $s->parse("\x11") # return 'UDP' $s->build("TCP") # returns "\x06" It is also possible to have a default: $s = Enum(Byte("protocol"), TCP => 6, UDP => 17, _default_ => blah => 99, ); $s->parse("\x12") # returns 'blah' Please note that the default tag must not be one of the supplied pairs. And finally: $s = Enum(Byte("protocol"), TCP => 6, UDP => 17, _default_ => $DefaultPass, ); $s->parse("\x12") # returns 18 $DefaultPass tells Enum that if it isn't familiar with the value, pass it alone. =head3 FlagsEnum If the field represent a set of flags, then the library provide a construct just for that: $s = FlagsEnum(ULInt16("characteristics"), RELOCS_STRIPPED => 0x0001, EXECUTABLE_IMAGE => 0x0002, LINE_NUMS_STRIPPED => 0x0004, REMOVABLE_RUN_FROM_SWAP => 0x0400, BIG_ENDIAN_MACHINE => 0x8000, ); $data = $s->parse("\2\4"); # $data is { EXECUTABLE_IMAGE => 1, REMOVABLE_RUN_FROM_SWAP => 1 }; Of course, this is equvalent to creating a BitStruct, and specifing Flag-s in the correct positions, and so on. but this is an easier way. =head2 Validators Validator... validate. they validate that the value on the stream is an expected one, and they validate that the value that need to be written to the stream is a correct one. otherwise, throws an exception. =head3 OneOf / NoneOf OneOf(UBInt8("foo"), [4,5,6,7])->parse("\x05") # return 5 OneOf(UBInt8("foo"), [4,5,6,7])->parse("\x08") # dies. NoneOf(UBInt8("foo"), [4,5,6,7])->parse("\x08") # returns 8 NoneOf(UBInt8("foo"), [4,5,6,7])->parse("\x05") # dies =head3 Const $s = Const(Bytes("magic", 6), "FOOBAR"); On parsing: verify that the correct value is being read, and return it. On building: if value is supplied, verify that it is the correct one. if the value is not supplied, insert the correct one. =head3 Magic Magic("\x89PNG\r\n\x1a\n") A constant string that is written / read and verified to / from the stream. For example, every PNG file starts with eight pre-defined bytes. this construct handle them, transparant to the calling program. (you don't need to supply a value, nor you will see the parsed value) =head2 BitStruct As said in the section about Bit-Primitives, these primitives are not packed tightly, and each will take complete bytes from the stream. If you need to pack them tightly, use BitStruct: $s = BitStruct("foo", BitField("a", 3), # three bit int Flag("b"), # one bit Nibble("c"), # four bit int BitField("d", 5), # five bit int ); $data = $s->parse("\xe1\xf2"); # $data is { a => 7, b => 0, c => 1, d => 30 } As can be seen, we start with 1110000111110010. The it is being splitted as a=111, b=0, c=0001, d=11110 and the rest (010) is discard. BitStruct can be inside other BitStruct. Inside BitStruct, Struct and BitStruct are equivalents. $s = BitStruct("foo", BitField("a", 3), Flag("b"), Nibble("c"), Struct("bar", Nibble("d"), Bit("e"), Octet("f"), ) ); $data = $s->parse("\xe1\xf2\x34"); # $data is { a => 7, b => 0, c => 1, bar => { d => 15, e => 0, f => 70 } } It is possible to mix a byte-primitives inside a BitStruct: $s = BitStruct("foo", BitField("a", 3), UBInt16("int data"), Nibble("b"), ); $data = $s->parse("\xe1\xf2\x34"); # $data is { a => 7, "int data" => 3985, b => 10 } Just be aware that this UBInt16 starts from the middle of the first byte, and ends in the middle of the third. BitStruct is based on a BitStream (see Stream) that is not seekable. So it can't contain any construct that require seekability. =head3 Bitwise Use Bitwise when you are not under a BitStream, and you have single construct that need to be packed by bits, and you don't want to create another hash for just this construct. Here is an example from BMP: Bitwise(Array(sub { $_->ctx(2)->{width} }, Nibble("index"))); We have an array of Nibble, that need to be packed together. =head2 ReversedBitStruct and ReversedBitField BitStruct assumes that each byte is arranged, bit-wise, from the most significante bit (MSB) to the least significante bit. (LSB) However, it is not always true. Lets say that you bytes are: MSB LSB Byte 1: A B C D E F G H Byte 2: I J K M L N O P And suppose that you have a bit-struct with three fields. AF1 is three bits, AF2 is one bit, and AF3 is eight bits. so if: AF1=ABC, AF2=D, AF3=EFGHIJKM use: BitStruct with BitField AF1=CBA, AF2=D, AF3=MKJIHGFE use: BitStruct with ReversedBitField AF1=HGF, AF2=E, AF3=DCBAPONL use: ReversedBitStruct with BitField AF1=FGH, AF2=E, AF3=LNOPABCD use: ReversedBitStruct with ReversedBitField =head2 Padding Padding remove bytes from the stream $s = Struct("foo", Padding(2), Flag("myflag"), Padding(5), ); $data = $s->parse("\x00\x00\x01\x00\x00\x00\x00\x00"); # $data is { myflag => 1 } However, if woring on Bit Stream, then Padding takes bits and not bytes $s = BitStruct("foo", Padding(2), Flag("myflag"), Padding(5), ); $data = $s->parse("\x20"); # $data is { myflag => 1 } Padding is a meta-construct, can take code ref instead of a number $s = Struct("foo", Byte("count"), Padding( sub { $_->ctx->{count} } ), Flag("myflag"), ); $data = $s->parse("\x02\0\0\1"); # $data is { count => 2, muflag => 1 } =head2 Peeking and Jumping Not all parsing is linear. sometimes you need to peek ahead to see if a certain value exists ahead, or maybe you know where the data is, it's just that it is some arbitary number of bytes ahead. or before. =head3 Pointer and Anchor Pointers are another animal of meta-struct. For example: $s = Struct("foo", Pointer(sub { 4 }, Byte("data1")), # <-- data1 is at (absolute) position 4 Pointer(sub { 7 }, Byte("data2")), # <-- data2 is at (absolute) position 7 ); $data = $s->parse("\x00\x00\x00\x00\x01\x00\x00\x02"); # $data is {data1=> 1 data2=>2 } Literaly is says: jump to position 4, read byte, return to the beginning, jump to position 7, read byte, return to the beginning. Anchor can help a Pointer to find it's target: $s = Struct("foo", Byte("padding_length"), Padding(sub { $_->ctx->{padding_length} } ), Byte("relative_offset"), Anchor("absolute_position"), Pointer(sub { $_->ctx->{absolute_position} + $_->ctx->{relative_offset} }, Byte("data")), ); $data = $s->parse("\x05\x00\x00\x00\x00\x00\x03\x00\x00\x00\xff"); # $data is { absolute_position=> 7, relative_offset => 3, data => 255, padding_length => 5 } Anchor saves the current location in the stream, enable the Pointer to jump to location relative to it. Also, $_->stream->tell will point you to the current location, giving the ability for relative location without using Anchor. The above construct is quevalent to: $s = Struct("foo", Byte("padding_length"), Padding(sub { $_->ctx->{padding_length} } ), Byte("relative_offset"), Pointer(sub { $_->stream->tell + $_->ctx->{relative_offset} }, Byte("data")), ); =head3 Peek $s = Struct("foo", Byte("a"), Peek(Byte("b")), Byte("c"), ); Peek is like Pointer with two differences: one that it is no-op on build. second the location is calculated relative to the current location, while with Pointer it's absolute position. If no distance is supplied, zero is assumed. it is posible to supply constant distance, (i.e. 5) or code ref. Examples: Peek(UBInt16("b"), 5) # Peek 5 bytes ahead Peek(UBInt16("b"), sub { $_->ctx->{this_far} }) # calculated number of bytes ahead =head2 Strings =head3 Char The Char construct represent a single character. This can mean one byte, or if it have encoding attached, a multi-byte character. $s = Char("c", "utf8"); $s->build("\x{1abcd}"); # returns "\xf0\x9a\xaf\x8d" The allowded encodings are: UTF-32LE UTF-32BE UTF-16LE UTF-16BE UTF-8 utf8 or any single-byte encoding supported by the Encode module for example: iso-8859-8 If you don't know if your unicode string is BE or LE, then it's probably BE. =head3 String (constant length / meta) A string with constant length: String("foo", 5)->parse("hello") # returns "hello" A string with variable length, and encoding: String("description", sub { $_->ctx->{description_size} }, encoding => 'UTF-16LE' ) The string length is specified in *characters*, not bytes. =head3 PaddedString A Padded string with constant length: $s = PaddedString("foo", 10, padchar => "X", paddir => "right"); $s->parse("helloXXXXX") # return "hello" $s->build("hello") # return 'helloXXXXX' I think that it speaks for itself. only that paddir can be one of qw{right left center}, and there can be also trimdir that can be "right" or "left". When encoding is supplied, for example: $s = PaddedString("foo", 10, encoding => "utf8"); The String length is still specified in *bytes*, not characters. If anyone ever encouter a padded constant length string with multi byte encoding that it's length is specified in characters, please send me an email. =head3 PascalString PascalString - String with a length marker in the beginning: $s = PascalString("foo"); $s->build("hello world") # returns "\x0bhello world" The marker can be of any kind: $s = PascalString("foo", \&UBInt16); $s->build("hello") # returns "\x00\x05hello" (the marker can be pointer to any function that get a name and return construct. And on parse that construct should return a value. like the built-in primitives for example) With encoding: $s = PascalString("foo", undef, "utf8"); The string length is specified in *characters*, not bytes. =head3 CString And finally, CString: $s = CString("foo"); $s->parse("hello\x00") # returns 'hello' Can have many optional terminators: $s = CString("foo", terminators => "XYZ"); $s->parse("helloY") # returns 'hello' With encoding: $s = CString("foo", encoding => "utf8"); =head2 Union / RoughUnion $s = Union("foo", UBInt32("a"), UBInt16("b") ); $data = $s->parse("\xaa\xbb\xcc\xdd"); # $data is { a => 2864434397, b => 43707 } A Union. currently work only with constant-size constructs, (like primitives, Struct and such) but not on bit-stream. $s = Struct("records", ULInt32("record_size"), RoughUnion("params", Field("raw", sub { $_->ctx(1)->{record_size} - 8 }), Array(sub { int(($_->ctx(1)->{record_size} - 8) / 4) }, ULInt32("params")), ), ); RoughUnion is a type of Union, that doesn't check the size of it's sub-constructs. it is used when we don't know before-hand the size of the sub-constructs, and the size of the union as a whole. In the above example, we assume that if the union target is the array of integers, then it probably record_size % 4 = 0. If it's not, and we build this construct from the array, then we will be a few bytes short. =head2 Aligned $s = Struct("bmp", ULInt32("width"), ULInt32("height"), Array( sub { $_->ctx->{height} }, Aligned( Array( sub { $_->ctx(2)->{width} }, Byte("index") ), 4), ), ); Aligned make sure that the contained construct's size if dividable by $modulo. the syntex is: Aligned($subcon, $modulo); In the above example, we have an excert from the BMP parser. each pixel is a byte. There is an array of lines (height) that each line is an array of pixels. each line is aligned to a four bytes boundary. The modulo can be any number. 2, 4, 8, 7, 23. =head2 Terminator Terminator()->parse("") verify that we reached the end of the stream. Not very useful, unless you are processing a file and need to verify that you have reached the end =head2 LasyBound This construct is estinental for recoursive constructs. $s = Struct("foo", Flag("has_next"), If(sub { $_->ctx->{has_next} }, LazyBound("next", sub { $s })), ); $data = $s->parse("\x01\x01\x01\x00"); # $data is: # { # has_next => 1, # next => { # has_next => 1, # next => { # has_next => 1, # next => { # has_next => 0, # next => undef # } # } # } # } =head2 Sequence Similar to Struct, just return an arrat reference instead of hash ref $s = Sequence("foo", UBInt8("a"), UBInt16("b"), Sequence("bar", UBInt8("a"), UBInt16("b"), ) ); $data = $s->parse("ABBabb"); # $data is [ 65, 16962, [ 97, 25186 ] ] Be aware that not every construct works well under Sequence. For example, Value will have problems on building. Using Struct is prefered. =head1 Depricated Constructs A few construct are being depricated - for the reason that while parsing a binary stream, you should know before-hand what are you going to get. If needed, it is possible to use Peek or Pointer to look ahead. These will be exported only by request, or by using the :all tag use Data::ParseBinary qw{:all}; use Data::ParseBinary qw{UNInt64 OptionalGreedyRange}; =head2 Primitives The following primitives are depricated, because I don't think it's good practice to declare a structure with native-order byte order. What if someone will run your program in a machine with the oposite byte order? N stand for Platform natural UNInt8 SNInt8 UNInt16 SNInt16 UNInt32 SNInt32 UNInt64 SNInt64 NFloat32 NFloat64 These will be exported only by request, or by using the :NATURALS tag use Data::ParseBinary qw{:NATURALS}; =head2 Ranges Please use Array, with constant or dynamic number of elements # This is an array for 3 to 7 bytes $s = Range(3, 7, UBInt8("foo")); $data = $s->parse("\x01\x02\x03"); $data = $s->parse("\x01\x02\x03\x04\x05\x06\x07\x08\x09"); # in the last example, will take only 7 bytes from the stream # A range with at least one byte, unlimited $s = GreedyRange(UBInt8("foo")); # A range with zero to unlimited bytes $s = OptionalGreedyRange(UBInt8("foo")); =head2 Optional Optional construct may or may not be in the stream. Of course, it need a seekable stream. The optional section usually have a Const in them, that indicates is this section exists. my $wmf_file = Struct("wmf_file", Optional( Struct("placeable_header", Const(ULInt32("key"), 0x9AC6CDD7), ULInt16("handle"), ), ), ULInt16("version"), ULInt32("size"), # file size is in words ); A better way is to Peek ahead, and decide if this part exists: my $wmf_file = Struct("wmf_file", Peek(ULInt32("header_key")), If(sub { $_->ctx->{header_key} == 0x9AC6CDD7 }, Struct("placeable_header", Const(ULInt32("key"), 0x9AC6CDD7), ULInt16("handle"), ), ), ULInt16("version"), ULInt32("size"), # file size is in words ); =head1 Streams Until now, everything worked in single-action. build built one construct, and parse parsed one construct from one string. But suppose the string have more then one construct in it? Suppose we want to write two constructs into one string? (and if these constructs are in bit-mode, we can't create and just join them) So, anyway, we have streams. A stream is an object that let a construct read and parse bytes from, or build and write bytes to. Please note, that some constructs can only work on seekable streams. =head2 String is seekable, not bit-stream This is the most basic stream. $data = $s->parse("aabb"); # is equivalent to: $stream = CreateStreamReader("aabb"); $data = $s->parse($stream); # also equivalent to: $stream = CreateStreamReader(String => "aabb"); $data = $s->parse($stream); Being that String is the default stream type, it is not needed to specify it. So, if there is a string contains two or more structs, that the following code is possible: $stream = CreateStreamReader(String => $my_string); $data1 = $s1->parse($stream); $data2 = $s2->parse($stream); The other way is equally possible: $stream = CreateStreamWriter(String => undef); $s1->build($data1); $s2->build($data2); $my_string = $stream->Flush(); The Flush command in Writer Stream says: finish doing whatever you do, and return your internal object. For string writer it is simply return the string that it built. Wrapping streams (like Bit, StringBuffer) finish whatever they are doing, flush the data to the internal stream, and call Flush on that internal stream. The special case here is Wrap, that does not call Flush on the internal stream. usefull for some configurations. a Flush operation happens in the end of every build operation automatically, and when a stream being destroyed. In creation, the following lines are equvalent: $stream = CreateStreamWriter(undef); $stream = CreateStreamWriter(''); $stream = CreateStreamWriter(String => undef); $stream = CreateStreamWriter(String => ''); Of course, it is possible to create String Stream with inital string to append to: $stream = CreateStreamWriter(String => "aabb"); And any sequencal build operation will append to the "aabb" string. =head2 StringRef is seekable, not bit-stream Mainly for cases when the string is to big to play around with. Writer: my $string = ''; $stream = CreateStreamWriter(StringRef => \$string); ... do build operations ... # and now the data in $string. # or refer to: ${ $stream->Flush() } Because Flush returns what's inside the stream - in this case a reference to a string. For Reader: my $string = 'MBs of data...'; $stream = CreateStreamReader(StringRef => \$string); ... parse operations ... =head2 Bit not seekable, is bit-stream While every stream support bit-fields, when requesting 2 bits in non-bit-streams you get these two bits, but a whole byte is consumed from the stream. In bit stream, only two bits are consumed. When you use BitStruct construct, it actually wraps the current stream with a bit stream. If the stream is already bit-stream, it continues as usual. What does it all have to do with you? great question. Support you have a string containing a few bit structs, and each struct is aligned to a byte border. Then you can use the example under the BitStruct section. However, if the bit structs are not aligned, but compressed one against the other, then you should use: $s = BitStruct("foo", Padding(1), Flag("myflag"), Padding(3), ); $inner = "\x42\0"; $stream1 = CreateStreamReader(Bit => String => $inner); $data1 = $s->parse($stream1); # data1 is { myflag => 1 } $data2 = $s->parse($stream1); # data2 is { myflag => 1 } $data3 = $s->parse($stream1); # data3 is { myflag => 0 } Note that the Padding constructs detects that it work on bit stream, and pad in bits instead of bytes. On Flush the bit stream write the reminding bits (up to a byte border) as 0, write the last byte to the contained stream, and call Flush on the said contained stream. so, if we use the $s from the previous code section: $stream1 = CreateStreamWriter(Bit => String => undef); $s->build({ myflag => 1 }, $stream1); $s->build({ myflag => 1 }, $stream1); $s->build({ myflag => 0 }, $stream1); my $result = $stream1->Flush(); # $result eq "\x40\x40\0" In this case each build operation did Flush on the bit stream, closing the last (and only) byte. so we get three bytes, each contain one record. But if we want that our constructs will be compressed each against the other, then we need to protect the bit stream from the Flush command: $stream1 = CreateStreamWriter(Wrap => Bit => String => undef); $s->build($data1, $stream1); $s->build($data1, $stream1); $s->build($data2, $stream1); my $result = $stream1->Flush()->Flush(); # $result eq "\x42\0"; Ohh. Two Flushs. one for the Wrap, one for the Bit and the String. However, as you can see, the structs are packed together. The Wrap stream protects the Bit stream from the Flush command in the end of every build. =head2 StringBuffer is seekable, not bit-stream Suppose that you have some non-seekable stream. like socket. and suppose that your struct do use construct that need seekable stream. What can you do? Enter StringBuffer. It reads from the warped stream exactly the number of bytes that the struct needs, giving the struct the option to seek inside the read section. and if the struct seeks ahead - it will just read enough bytes to seek to this place. In writer stream, the StringBuffer will pospone writing the data to the actual stream, until the Flush command. This warper stream is usefull only when the struct seek inside it's borders, and not sporadically reads data from 30 bytes ahead / back. # suppose we have unseekable reader stream names $s_stream # (for example, TCP connection) $stream1 = CreateStreamReader(StringBuffer => $s_stream); # $s is some struct that uses seek. (using Peek, for example) $data = $s->parse($stream1); # the data were read, you can either drop $stream1 or continue use # it for future parses. # now suppose we have a unseekable writer strea name $w_stream $stream1 = CreateStreamWriter(StringBuffer => $w_stream); # $s is some struct that uses seek. (using Peek, for example) $s->build($data1, $stream1); # data is written into $stream1, flushed to $w_stream, and sent. Note that in StringBuffer, the Flush operation writes the data to the underlining stream, and then Flushes that stream. =head2 Wrap A simple wraping stream, whose only function is to protect the contained stream from Flush commands. Usable only for writer streams, and can be used to: 1. Protect a Bit stream, so it will compress multiple structs without byte alignment (see the Bit stream documentation for example) 2. Protect a StringBuffer, so it will aggregate some structs before you will Flush them all as one to the socket/file/whatever. =head2 File is seekable, not bit-stream Reads from / Writes to a file. it is your responsebility to open the file and binmode it. open my $fh, "<", "bin_data.xdf" or die "oh sh..."; binmode $fh; $stream1 = CreateStreamReader(File => $fh); =head1 Format Library The Data::ParseBinary arrive with ever-expanding set of pre-defined parsers for popular formats. Each of these parsers is in it's own module. And if you have a file-format, then this is how it's done: use Data::ParseBinary::Graphics::BMP qw{$bmp_parser}; open my $fh2, "<", $filename or die "can not open $filename"; binmode $fh2; $data = $bmp_parser->parse(CreateStreamReader(File => $fh2)); And $data will contain the parsed file. In the same way, it is possible to build a BMP file. Please look for the documentation inside each module, as it highlights various issues with the various libraries. =head1 Debugging =head2 Output on failure The first line of defence is the output on error. Where did it happend? in which construct? In which byte of the input? On error, you get the following "die" messege: Got Exception not enought bytes in stream Streams location: 1: Stream BitReader in byte #Bit 5 2: Stream StringReader in byte #2 Constructs Stack: 1: BitField f 2: Struct bar 3: BitStruct foo It tells me that I was inside "f" under "bar" under "foo", that it's the second byte in stream, and because I was inside a BitStuct I get another line for the stream, pointing me to the exact bit. =head2 $print_debug_info What we miss in the "die" messege above, is knowing how did I got there. If it's inside Array, how many times it happen, and what decissions taken along the way. But fear not. just set $print_debug_info: $Data::ParseBinary::print_debug_info = 1; This will trigger a print every time the parsing process enter or exit a construct. So if a parsing dies, you can follow where it did. =head1 TODO The following elements were not implemented: OnDemand Reconfig and a macro Rename AlignedStruct Probe Embed Tunnel (TunnelAdapter is already implemented) Add documentation to: ExtractingAdapter Move the insertion of the parsed value to the context from the Struct/Sequence constructs to each indevidual construct? Streams: SocketStream FileStreamWriter::Flush : improve. Ability to give the CreateStreamReader/CreateStreamWriter function an ability to reconginze socket / filehandle / pointer to string. Union need to be extended to bit-structs? use some nice exception system Fix the Graphics-EMF library : Find out if the EMF file should work or not. it fails on the statment: Const(ULInt32("signature"), 0x464D4520) And complain that it gets "0". Make BitField a meta construct? =head1 Thread Safety This is a pure perl module. there should be not problems. =head1 BUGS Currently L/BFloat64 does not work if you don't have 64 bit numbers support compiled in your Perl =head1 SEE ALSO Original PyConstructs homepage: http://construct.wikispaces.com/ =head1 AUTHOR Fomberg Shmuel, Eowner@semuel.co.ilE =head1 COPYRIGHT AND LICENSE Copyright 2008 by Shmuel Fomberg. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/0000755000000000000000000000000011535704017020124 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Adapters.pm0000755000000000000000000002632711524350240022233 0ustar rootrootuse strict; use warnings; use Data::ParseBinary::Core; package Data::ParseBinary::Enum; our @ISA = qw{Data::ParseBinary::Adapter}; # TODO: implement as macro in terms of SymmetricMapping (macro) # that is implemented as MappingAdapter sub _init { my ($self, @params) = @_; my $decode = {}; my $encode = {}; $self->{have_default} = 0; $self->{default_action} = undef; while (@params) { my $key = shift @params; my $value = shift @params; if ($key eq '_default_') { $self->{have_default} = 1; $self->{default_action} = $value; if (ref $value) { if ($value != $Data::ParseBinary::BaseConstruct::DefaultPass) { die "Enum Error: got invalid value as default"; } } elsif (exists $encode->{$value}) { die "Enum Error: $value should not be defined as regular case"; } else { $self->{default_value} = shift @params; } next; } $encode->{$key} = $value; $decode->{$value} = $key; } $self->{encode} = $encode; $self->{decode} = $decode; } sub _decode { my ($self, $value) = @_; if (exists $self->{decode}->{$value}) { return $self->{decode}->{$value}; } if ($self->{have_default}) { if (ref($self->{default_action}) and $self->{default_action} == $Data::ParseBinary::BaseConstruct::DefaultPass) { return $value; } return $self->{default_action}; } die "Enum: unrecognized value $value, and no default defined"; } sub _encode { my ($self, $tvalue) = @_; if (exists $self->{encode}->{$tvalue}) { return $self->{encode}->{$tvalue}; } if ($self->{have_default}) { if (ref($self->{default_action}) and $self->{default_action} == $Data::ParseBinary::BaseConstruct::DefaultPass) { return $tvalue; } return $self->{default_value}; } die "Enum: unrecognized value $tvalue"; } package Data::ParseBinary::FlagsEnum; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, @mapping) = @_; my @pairs; die "FlagsEnum: Mapping should be even" if @mapping % 2 == 1; while (@mapping) { my $name = shift @mapping; my $value = shift @mapping; push @pairs, [$name, $value]; } $self->{pairs} = \@pairs; } sub _decode { my ($self, $value) = @_; my $hash = {}; foreach my $rec (@{ $self->{pairs} }) { $hash->{$rec->[0]} = 1 if $value & $rec->[1]; } return $hash; } sub _encode { my ($self, $tvalue) = @_; my $value = 0; foreach my $rec (@{ $self->{pairs} }) { if (exists $tvalue->{$rec->[0]} and $tvalue->{$rec->[0]}) { $value |= $rec->[1]; } } return $value; } package Data::ParseBinary::ExtractingAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, $sub_name) = @_; $self->{sub_name} = $sub_name; } sub _decode { my ($self, $value) = @_; return $value->{$self->{sub_name}}; } sub _encode { my ($self, $tvalue) = @_; return {$self->{sub_name} => $tvalue}; } package Data::ParseBinary::IndexingAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, $index) = @_; $self->{index} = $index || 0; } sub _decode { my ($self, $value) = @_; return $value->[$self->{index}]; } sub _encode { my ($self, $tvalue) = @_; return [ ('') x $self->{index}, $tvalue ]; } package Data::ParseBinary::JoinAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _decode { my ($self, $value) = @_; return join '', @$value; } sub _encode { my ($self, $tvalue) = @_; return [split '', $tvalue]; } package Data::ParseBinary::ConstAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, $value) = @_; $self->{value} = $value; } sub _decode { my ($self, $value) = @_; if (not $value eq $self->{value}) { die "Const Error: expected $self->{value} got $value"; } return $value; } sub _encode { my ($self, $tvalue) = @_; if (not defined $self->_get_name()) { # if we don't have a name, then just use the value return $self->{value}; } if (defined $tvalue and $tvalue eq $self->{value}) { return $self->{value}; } die "Const Error: expected $self->{value} got ". (defined $tvalue ? $tvalue : "undef"); } package Data::ParseBinary::LengthValueAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _decode { my ($self, $value) = @_; return $value->[1]; } sub _encode { my ($self, $tvalue) = @_; return [length($tvalue), $tvalue]; } package Data::ParseBinary::PaddedStringAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, %params) = @_; if (not defined $params{length}) { die "PaddedStringAdapter: you must specify length"; } $self->{length} = $params{length}; $self->{encoding} = $params{encoding}; $self->{padchar} = defined $params{padchar} ? $params{padchar} : "\x00"; $self->{paddir} = $params{paddir} || "right"; $self->{trimdir} = $params{trimdir} || "right"; if (not grep($_ eq $self->{paddir}, qw{right left center})) { die "PaddedStringAdapter: paddir should be one of {right left center}"; } if (not grep($_ eq $self->{trimdir}, qw{right left})) { die "PaddedStringAdapter: trimdir should be one of {right left}"; } } sub _decode { my ($self, $value) = @_; my $tvalue = $value; my $char = $self->{padchar}; if ($self->{paddir} eq 'right' or $self->{paddir} eq 'center') { $tvalue =~ s/$char*\z//; } elsif ($self->{paddir} eq 'left' or $self->{paddir} eq 'center') { $tvalue =~ s/\A$char*//; } return $tvalue; } sub _encode { my ($self, $tvalue) = @_; my $value = $tvalue; if (length($value) < $self->{length}) { my $add = $self->{length} - length($value); my $char = $self->{padchar}; if ($self->{paddir} eq 'right') { $value .= $char x $add; } elsif ($self->{paddir} eq 'left') { $value = ($char x $add) . $value; } elsif ($self->{paddir} eq 'center') { my $add_left = $add / 2; my $add_right = $add_left + ($add % 2 == 0 ? 0 : 1); $value = ($char x $add_left) . $value . ($char x $add_right); } } if (length($value) > $self->{length}) { my $remove = length($value) - $self->{length}; if ($self->{trimdir} eq 'right') { substr($value, $self->{length}, $remove, ''); } elsif ($self->{trimdir} eq 'left') { substr($value, 0, $remove, ''); } } return $value; } #package Data::ParseBinary::StringAdapter; #our @ISA = qw{Data::ParseBinary::Adapter}; # #sub _init { # my ($self, $encoding) = @_; # $self->{encoding} = $encoding; #} # #sub _decode { # my ($self, $value) = @_; # my $tvalue; # if ($self->{encoding}) { # die "TODO: Should implement different encodings"; # } else { # $tvalue = $value; # } # return $tvalue; #} # #sub _encode { # my ($self, $tvalue) = @_; # my $value; # if ($self->{encoding}) { # die "TODO: Should implement different encodings"; # } else { # $value = $tvalue; # } # return $value; #} package Data::ParseBinary::CStringAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, $terminators) = @_; $self->{regex} = qr/[$terminators]*\z/; $self->{terminator} = substr($terminators, 0, 1); } sub _decode { my ($self, $value) = @_; $value =~ s/$self->{regex}//; return $value; } sub _encode { my ($self, $tvalue) = @_; return $tvalue . $self->{terminator}; } package Data::ParseBinary::LamdaValidator; our @ISA = qw{Data::ParseBinary::Validator}; sub _init { my ($self, @params) = @_; $self->{coderef} = shift @params; } sub _validate { my ($self, $value) = @_; return $self->{coderef}->($value); } package Data::ParseBinary::FirstUnitAndTheRestAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; # this adapter move from a length of bytes, to one unit and the rest # as an array sub _init { my ($self, $unit_length, $first_name, $the_rest) = @_; $first_name ||= 'FirstUnit'; $the_rest ||= 'TheRest'; $self->{unit_length} = $unit_length; $self->{first_name} = $first_name; $self->{the_rest} = $the_rest; } sub _decode { my ($self, $value) = @_; $value = join('', $value->{$self->{first_name}}, @{ $value->{$self->{the_rest}} } ); return $value; } sub _encode { my ($self, $tvalue) = @_; my $u_len = $self->{unit_length}; die "Length of input should be dividable by unit_length" unless length($tvalue) % $u_len == 0; my @units = map substr($tvalue, $_*$u_len, $u_len), 0..(length($tvalue) / $u_len - 1); my $first = shift @units; my $value = { $self->{first_name} => $first, $self->{the_rest} => \@units }; return $value; } package Data::ParseBinary::CharacterEncodingAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, $encoding) = @_; $self->{encoding} = $encoding; require Encode; } sub _decode { my ($self, $octets) = @_; my $string = Encode::decode($self->{encoding}, $octets); return $string; } sub _encode { my ($self, $string) = @_; my $octets = Encode::encode($self->{encoding}, $string); return $octets; } package Data::ParseBinary::ExtendedNumberAdapter; our @ISA = qw{Data::ParseBinary::Adapter}; sub _init { my ($self, $is_signed, $is_bigendian) = @_; $self->{is_signed} = $is_signed; $self->{is_bigendian} = $is_bigendian; require Math::BigInt; } sub _decode { my ($self, $value) = @_; if (not $self->{is_bigendian}) { $value = join '', reverse split '', $value; } my $is_negative; if ($self->{is_signed}) { my $first_char = ord($value); if ($first_char > 127) { $value = ~$value; $is_negative = 1; } } my $hexed = unpack "H*", $value; my $number = Math::BigInt->new("0x$hexed"); if ($is_negative) { $number->binc()->bneg(); } return $number; } sub _encode { my ($self, $number) = @_; $number = Math::BigInt->new($number); my $is_negative; if ($self->{is_signed}) { if ($number->sign() eq '-') { $is_negative = 1; $number->binc()->babs(); } } else { if ($number->sign() eq '-') { die "Was given a negative number for unsigned integer"; } } my $hexed = $number->as_hex(); substr($hexed, 0, 2, ''); my $packed = pack "H*", ("0"x(16-length($hexed))).$hexed; if ($is_negative) { $packed = ~$packed; } if (not $self->{is_bigendian}) { $packed = join '', reverse split '', $packed; } return $packed; } 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Executable/0000755000000000000000000000000011535704017022205 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Executable/PE32.pm0000755000000000000000000003464411476437742023246 0ustar rootrootpackage Data::ParseBinary::Executable::PE32; use strict; use warnings; use Data::ParseBinary; #Portable Executable (PE) 32 bit, little endian #Used on MSWindows systems (including DOS) for EXEs and DLLs # #1999 paper: #http://download.microsoft.com/download/1/6/1/161ba512-40e2-4cc9-843a-923143f3456c/pecoff.doc # #2006 with updates relevant for .NET: #http://download.microsoft.com/download/9/c/5/9c5b2167-8017-4bae-9fde-d599bac8184a/pecoff_v8.doc sub UTCTimeStamp { my ($name) = @_; return Data::ParseBinary::lib::ExecPE32::UTCTimeStampAdapter->create(ULInt32($name)); } my $msdos_header = Struct("msdos_header", Magic("MZ"), ULInt16("partPag"), ULInt16("page_count"), ULInt16("relocation_count"), ULInt16("header_size"), ULInt16("minmem"), ULInt16("maxmem"), ULInt16("relocation_stackseg"), ULInt16("exe_stackptr"), ULInt16("checksum"), ULInt16("exe_ip"), ULInt16("relocation_codeseg"), ULInt16("table_offset"), ULInt16("overlay"), Padding(8), ULInt16("oem_id"), ULInt16("oem_info"), Padding(20), ULInt32("coff_header_pointer"), Anchor("_assembly_start"), Field("code", sub { $_->ctx->{coff_header_pointer} - $_->ctx->{_assembly_start} } ), ); my $symbol_table = Struct("symbol_table", String("name", 8, padchar => "\x00"), ULInt32("value"), Enum( Data::ParseBinary::lib::ExecPE32::OneDownAdapter->create(SLInt16("section_number")), #ExprAdapter(SLInt16("section_number"), # encoder => sub { $_->obj + 1 }, # decoder => sub { $_->obj - 1 }, #), UNDEFINED => -1, ABSOLUTE => -2, DEBUG => -3, _default_ => $DefaultPass, ), Enum(ULInt8("complex_type"), NULL => 0, POINTER => 1, FUNCTION => 2, ARRAY => 3, ), Enum(ULInt8("base_type"), NULL => 0, VOID => 1, CHAR => 2, SHORT => 3, INT => 4, LONG => 5, FLOAT => 6, DOUBLE => 7, STRUCT => 8, UNION => 9, ENUM => 10, MOE => 11, BYTE => 12, WORD => 13, UINT => 14, DWORD => 15, ), Enum(ULInt8("storage_class"), END_OF_FUNCTION => 255, NULL => 0, AUTOMATIC => 1, EXTERNAL => 2, STATIC => 3, REGISTER => 4, EXTERNAL_DEF => 5, LABEL => 6, UNDEFINED_LABEL => 7, MEMBER_OF_STRUCT => 8, ARGUMENT => 9, STRUCT_TAG => 10, MEMBER_OF_UNION => 11, UNION_TAG => 12, TYPE_DEFINITION => 13, UNDEFINED_STATIC => 14, ENUM_TAG => 15, MEMBER_OF_ENUM => 16, REGISTER_PARAM => 17, BIT_FIELD => 18, BLOCK => 100, FUNCTION => 101, END_OF_STRUCT => 102, FILE => 103, SECTION => 104, WEAK_EXTERNAL => 105, ), ULInt8("number_of_aux_symbols"), Array(sub { $_->ctx->{number_of_aux_symbols} }, Bytes("aux_symbols", 18) ) ); my $coff_header = Struct("coff_header", Magic("PE\x00\x00"), Enum(ULInt16("machine_type"), UNKNOWN => 0x0, AM33 => 0x1d3, AMD64 => 0x8664, ARM => 0x1c0, EBC => 0xebc, I386 => 0x14c, IA64 => 0x200, M32R => 0x9041, MIPS16 => 0x266, MIPSFPU => 0x366, MIPSFPU16 => 0x466, POWERPC => 0x1f0, POWERPCFP => 0x1f1, R4000 => 0x166, SH3 => 0x1a2, SH3DSP => 0x1a3, SH4 => 0x1a6, SH5=> 0x1a8, THUMB => 0x1c2, WCEMIPSV2 => 0x169, _default_ => $DefaultPass ), ULInt16("number_of_sections"), UTCTimeStamp("time_stamp"), ULInt32("symbol_table_pointer"), ULInt32("number_of_symbols"), ULInt16("optional_header_size"), FlagsEnum(ULInt16("characteristics"), RELOCS_STRIPPED => 0x0001, EXECUTABLE_IMAGE => 0x0002, LINE_NUMS_STRIPPED => 0x0004, LOCAL_SYMS_STRIPPED => 0x0008, AGGRESSIVE_WS_TRIM => 0x0010, LARGE_ADDRESS_AWARE => 0x0020, MACHINE_16BIT => 0x0040, BYTES_REVERSED_LO => 0x0080, MACHINE_32BIT => 0x0100, DEBUG_STRIPPED => 0x0200, REMOVABLE_RUN_FROM_SWAP => 0x0400, SYSTEM => 0x1000, DLL => 0x2000, UNIPROCESSOR_ONLY => 0x4000, BIG_ENDIAN_MACHINE => 0x8000, ), # symbol table Pointer(sub { $_->ctx->{symbol_table_pointer} }, Array(sub { $_->ctx->{number_of_symbols} }, $symbol_table) ) ); sub PEPlusField { my ($name) = @_; return IfThenElse($name, sub { $_->ctx->{pe_type} eq "PE32_plus" }, ULInt64(undef), ULInt32(undef), ); } my $optional_header = Struct("optional_header", # standard fields Enum(ULInt16("pe_type"), PE32 => 0x10b, PE32_plus => 0x20b, ), ULInt8("major_linker_version"), ULInt8("minor_linker_version"), ULInt32("code_size"), ULInt32("initialized_data_size"), ULInt32("uninitialized_data_size"), ULInt32("entry_point_pointer"), ULInt32("base_of_code"), # only in PE32 files If(sub { $_->ctx->{pe_type} eq "PE32" }, ULInt32("base_of_data") ), # WinNT-specific fields PEPlusField("image_base"), ULInt32("section_aligment"), ULInt32("file_alignment"), ULInt16("major_os_version"), ULInt16("minor_os_version"), ULInt16("major_image_version"), ULInt16("minor_image_version"), ULInt16("major_subsystem_version"), ULInt16("minor_subsystem_version"), Padding(4), ULInt32("image_size"), ULInt32("headers_size"), ULInt32("checksum"), Enum(ULInt16("subsystem"), UNKNOWN => 0, NATIVE => 1, WINDOWS_GUI => 2, WINDOWS_CUI => 3, POSIX_CIU => 7, WINDOWS_CE_GUI => 9, EFI_APPLICATION => 10, EFI_BOOT_SERVICE_DRIVER => 11, EFI_RUNTIME_DRIVER => 12, EFI_ROM => 13, XBOX => 14, _defualt_ => $DefaultPass ), FlagsEnum(ULInt16("dll_characteristics"), NO_BIND => 0x0800, WDM_DRIVER => 0x2000, TERMINAL_SERVER_AWARE => 0x8000, ), PEPlusField("reserved_stack_size"), PEPlusField("stack_commit_size"), PEPlusField("reserved_heap_size"), PEPlusField("heap_commit_size"), ULInt32("loader_flags"), ULInt32("number_of_data_directories"), Data::ParseBinary::lib::ExecPE32::NamedSequence->create( Array(sub { $_->ctx->{number_of_data_directories} }, Struct("data_directories", ULInt32("address"), ULInt32("size"), ) ), mapping => { 0 => 'export_table', 1 => 'import_table', 2 => 'resource_table', 3 => 'exception_table', 4 => 'certificate_table', 5 => 'base_relocation_table', 6 => 'debug', 7 => 'architecture', 8 => 'global_ptr', 9 => 'tls_table', 10 => 'load_config_table', 11 => 'bound_import', 12 => 'import_address_table', 13 => 'delay_import_descriptor', 14 => 'complus_runtime_header', } ), ); my $section = Struct("section", String("name", 8, padchar => "\x00"), ULInt32("virtual_size"), ULInt32("virtual_address"), ULInt32("raw_data_size"), ULInt32("raw_data_pointer"), ULInt32("relocations_pointer"), ULInt32("line_numbers_pointer"), ULInt16("number_of_relocations"), ULInt16("number_of_line_numbers"), FlagsEnum(ULInt32("characteristics"), TYPE_REG => 0x00000000, TYPE_DSECT => 0x00000001, TYPE_NOLOAD => 0x00000002, TYPE_GROUP => 0x00000004, TYPE_NO_PAD => 0x00000008, TYPE_COPY => 0x00000010, CNT_CODE => 0x00000020, CNT_INITIALIZED_DATA => 0x00000040, CNT_UNINITIALIZED_DATA => 0x00000080, LNK_OTHER => 0x00000100, LNK_INFO => 0x00000200, TYPE_OVER => 0x00000400, LNK_REMOVE => 0x00000800, LNK_COMDAT => 0x00001000, MEM_FARDATA => 0x00008000, MEM_PURGEABLE => 0x00020000, MEM_16BIT => 0x00020000, MEM_LOCKED => 0x00040000, MEM_PRELOAD => 0x00080000, ALIGN_1BYTES => 0x00100000, ALIGN_2BYTES => 0x00200000, ALIGN_4BYTES => 0x00300000, ALIGN_8BYTES => 0x00400000, ALIGN_16BYTES => 0x00500000, ALIGN_32BYTES => 0x00600000, ALIGN_64BYTES => 0x00700000, ALIGN_128BYTES => 0x00800000, ALIGN_256BYTES => 0x00900000, ALIGN_512BYTES => 0x00A00000, ALIGN_1024BYTES => 0x00B00000, ALIGN_2048BYTES => 0x00C00000, ALIGN_4096BYTES => 0x00D00000, ALIGN_8192BYTES => 0x00E00000, LNK_NRELOC_OVFL => 0x01000000, MEM_DISCARDABLE => 0x02000000, MEM_NOT_CACHED => 0x04000000, MEM_NOT_PAGED => 0x08000000, MEM_SHARED => 0x10000000, MEM_EXECUTE => 0x20000000, MEM_READ => 0x40000000, MEM_WRITE => 0x80000000, ), Pointer(sub { $_->ctx->{raw_data_pointer} }, Field("raw_data", sub { $_->ctx->{raw_data_size} }) ), Pointer(sub { $_->ctx->{line_numbers_pointer} }, Array(sub { $_->ctx->{number_of_line_numbers} }, Struct("line_numbers", ULInt32("type"), ULInt16("line_number"), ) ) ), Pointer(sub { $_->ctx->{relocations_pointer} }, Array(sub { $_->ctx->{number_of_relocations} }, Struct("relocations", ULInt32("virtual_address"), ULInt32("symbol_table_index"), ULInt16("type"), ) ) ), ); sub min { my @values = @_; return undef if @values == 0; my $ret_val = $values[0]; foreach my $val (@values) { if ($val < $ret_val) { $ret_val = $val; } } } our $pe32_parser = Struct("pe32_file", # headers $msdos_header, $coff_header, Anchor("_start_of_optional_header"), $optional_header, Anchor("_end_of_optional_header"), Padding(sub { min(0, $_->ctx->{coff_header}->{optional_header_size} - $_->ctx->{_end_of_optional_header} + $_->ctx->{_start_of_optional_header} ) } ), # sections Array(sub { $_->ctx->{coff_header}->{number_of_sections} }, $section), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($pe32_parser); package Data::ParseBinary::lib::ExecPE32::OneDownAdapter; our @ISA; BEGIN { @ISA = qw{Data::ParseBinary::Adapter}; } sub _decode { my ($self, $value) = @_; return $value - 1; } sub _encode { my ($self, $tvalue) = @_; return $tvalue + 1; } package Data::ParseBinary::lib::ExecPE32::UTCTimeStampAdapter; our @ISA; BEGIN { @ISA = qw{Data::ParseBinary::Adapter}; } sub _decode { my ($self, $value) = @_; return $value; #return time.ctime(obj) } sub _encode { my ($self, $tvalue) = @_; return $tvalue; #return int(time.mktime(time.strptime(obj))) } package Data::ParseBinary::lib::ExecPE32::NamedSequence; our @ISA; BEGIN { @ISA = qw{Data::ParseBinary::Adapter}; } #""" #creates a mapping between the elements of a sequence and their respective #names. this is useful for sequences of a variable length, where each #element in the sequence has a name (as is the case with the data #directories of the PE header) #""" sub _init { my ($self, %params) = @_; die "You need to specify mapping to NamedSequence" unless $params{mapping}; $self->{mapping} = $params{mapping}; my $rev_mapping = {}; while (my ($key, $val) = each %{ $params{mapping} }) { $rev_mapping->{$val} = $key; } $self->{rev_mapping} = $rev_mapping; } sub _decode { my ($self, $value) = @_; my $tvalue = {}; foreach my $ix (0..$#$value) { my $name = $ix; $name = $self->{mapping}->{$name} if exists $self->{mapping}->{$name}; $tvalue->{$name} = $value->[$ix]; } return $tvalue; } sub _encode { my ($self, $tvalue) = @_; my $value = []; while (my ($key, $val) = each %$tvalue) { my $index = $key; if (exists $self->{rev_mapping}->{$index}) { $index = $self->{rev_mapping}->{$index}; } elsif ($index !~ /^\d+$/) { die "NamedSequence: encoded value should be either a recognized name or a number"; } $value->[$index] = $val; } return $value; } #__slots__ = ["mapping", "rev_mapping"] #prefix = "unnamed_" #def __init__(self, subcon, mapping): # Adapter.__init__(self, subcon) # self.mapping = mapping # self.rev_mapping = dict((v, k) for k, v in mapping.iteritems()) #def _encode(self, obj, context): # d = obj.__dict__ # obj2 = [None] * len(d) # for name, value in d.iteritems(): # if name in self.rev_mapping: # index = self.rev_mapping[name] # elif name.startswith("__"): # obj2.pop(-1) # continue # elif name.startswith(self.prefix): # index = int(name.split(self.prefix)[1]) # else: # raise ValueError("no mapping defined for %r" % (name,)) # obj2[index] = value # return obj2 #def _decode(self, obj, context): # obj2 = Container() # for i, item in enumerate(obj): # if i in self.mapping: # name = self.mapping[i] # else: # name = "%s%d" % (self.prefix, i) # setattr(obj2, name, item) # return obj2 1; __END__ =head1 NAME Data::ParseBinary::Executable::PE32 - Parsing Win32 EXE / DLL files =head1 SYNOPSIS use Data::ParseBinary::Executable::PE32 qw{$pe32_parser}; my $data = $pe32_parser->parse(CreateStreamReader(File => $fh)); Can parse a Windows (and DOS?) EXE and DLL files. However, when building it back, there are some minor differences from the original file, and Windows declare that it's not a valid Win32 application. This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Executable/ELF32.pm0000755000000000000000000000732711476437705023345 0ustar rootrootpackage Data::ParseBinary::Executable::ELF32; use strict; use warnings; use Data::ParseBinary; #""" #Executable and Linkable Format (ELF), 32 bit, little endian #Used on *nix systems as a replacement of the older a.out format #""" my $elf32_program_header = Struct("program_header", Enum(ULInt32("type"), NULL => 0, LOAD => 1, DYNAMIC => 2, INTERP => 3, NOTE => 4, SHLIB => 5, PHDR => 6, _default_ => $DefaultPass, ), ULInt32("offset"), ULInt32("vaddr"), ULInt32("paddr"), ULInt32("file_size"), ULInt32("mem_size"), ULInt32("flags"), ULInt32("align"), ); my $elf32_section_header = Struct("section_header", ULInt32("name_offset"), Pointer(sub { $_->ctx(2)->{strtab_data_offset} + $_->ctx->{name_offset} }, CString("name") ), Enum(ULInt32("type"), NULL => 0, PROGBITS => 1, SYMTAB => 2, STRTAB => 3, RELA => 4, HASH => 5, DYNAMIC => 6, NOTE => 7, NOBITS => 8, REL => 9, SHLIB => 10, DYNSYM => 11, _default_ => $DefaultPass, ), ULInt32("flags"), ULInt32("addr"), ULInt32("offset"), ULInt32("size"), ULInt32("link"), ULInt32("info"), ULInt32("align"), ULInt32("entry_size"), Pointer(sub { $_->ctx->{offset} }, Field("data", sub { $_->ctx->{size} }) ), ); our $elf32_parser = Struct("elf32_file", Struct("identifier", Const(Bytes("magic", 4), "\x7fELF"), Enum(Byte("file_class"), NONE => 0, CLASS32 => 1, CLASS64 => 2, ), Enum(Byte("encoding"), NONE => 0, LSB => 1, MSB => 2, ), Byte("version"), Padding(9), ), Enum(ULInt16("type"), NONE => 0, RELOCATABLE => 1, EXECUTABLE => 2, SHARED => 3, CORE => 4, ), Enum(ULInt16("machine"), NONE => 0, M32 => 1, SPARC => 2, I386 => 3, Motorolla68K => 4, Motorolla88K => 5, Intel860 => 7, MIPS => 8, ), ULInt32("version"), ULInt32("entry"), ULInt32("ph_offset"), ULInt32("sh_offset"), ULInt32("flags"), ULInt16("header_size"), ULInt16("ph_entry_size"), ULInt16("ph_count"), ULInt16("sh_entry_size"), ULInt16("sh_count"), ULInt16("strtab_section_index"), # calculate the string table data offset (pointer arithmetics) # ugh... anyway, we need it in order to read the section names, later on Pointer(sub { $_->ctx->{sh_offset} + $_->ctx->{strtab_section_index} * $_->ctx->{sh_entry_size} + 16 }, ULInt32("strtab_data_offset"), ), # program header table Pointer(sub { $_->ctx->{ph_offset} }, Array(sub { $_->ctx->{ph_count} }, $elf32_program_header ) ), # section table Pointer(sub { $_->ctx->{sh_offset} }, Array(sub { $_->ctx->{sh_count} }, $elf32_section_header ) ), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($elf32_parser); 1; __END__ =head1 NAME Data::ParseBinary::Executable::ELF32 - Parsing UNIX's SO files =head1 SYNOPSIS use Data::ParseBinary::Executable::ELF32 qw{$elf32_parser}; my $data = $elf32_parser->parse(CreateStreamReader(File => $fh)); Can parse and re-build UNIX "so" files. This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. No known issues =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Streams.pm0000755000000000000000000001043111527500244022077 0ustar rootrootpackage Data::ParseBinary::Stream::Reader; use strict; use warnings; sub _readBitsForByteStream { my ($self, $bitcount) = @_; my $count = int($bitcount / 8) + ($bitcount % 8 ? 1 : 0); my $data = $self->ReadBytes($count); my $fullbits = unpack "B*", $data; my $string = substr($fullbits, -$bitcount); return $string; } sub _readBytesForBitStream { my ($self, $count) = @_; my $bitData = $self->ReadBits($count * 8); my $data = pack "B*", $bitData; return $data; } sub isBitStream { die "unimplemented" } sub ReadBytes { die "unimplemented" } sub ReadBits { die "unimplemented" } sub seek { die "unimplemented" } sub tell { die "unimplemented" } our %_streamTypes; sub _registerStreamType { my ($class, $typeName) = @_; $_streamTypes{$typeName} = $class; } sub CreateStreamReader { my @params = @_; if (@params == 0) { die "CreateStreamReader: mush have a parameter"; } if (@params == 1) { my $source = $params[0]; if (not defined $source or not ref $source) { # some value (string?). let's feed it to StringStreamWriter return $_streamTypes{String}->new($source); } if (UNIVERSAL::isa($source, "Data::ParseBinary::Stream::Reader")) { return $source; } die "Got unknown input to CreateStreamReader"; } # @params > 1 my $source = pop @params; while (@params) { my $opts = undef; my $type = pop @params; if ( defined( ref $type ) and @params and ( $params[-1] eq ' Opts' ) ) { $opts = $type; $type = pop @params; } if (not exists $_streamTypes{$type}) { die "CreateStreamReader: Unrecognized type: $type"; } $source = $_streamTypes{$type}->new($source, $opts); } return $source; } sub DESTROY { my $self = shift; if ($self->can("disconnect")) { $self->disconnect(); } } package Data::ParseBinary::Stream::Writer; sub WriteBytes { die "unimplemented" } sub WriteBits { die "unimplemented" } sub Flush { die "unimplemented" } sub isBitStream { die "unimplemented" } sub seek { die "unimplemented" } sub tell { die "unimplemented" } sub _writeBitsForByteStream { my ($self, $bitdata) = @_; my $data_len = length($bitdata); my $zeros_to_add = (-$data_len) % 8; my $binary = pack "B".($zeros_to_add + $data_len), ('0'x$zeros_to_add).$bitdata; return $self->WriteBytes($binary); } sub _writeBytesForBitStream { my ($self, $data) = @_; my $bitdata = unpack "B*", $data; return $self->WriteBits($bitdata); } our %_streamTypes; sub _registerStreamType { my ($class, $typeName) = @_; $_streamTypes{$typeName} = $class; } sub CreateStreamWriter { my @params = @_; if (@params == 0) { return $_streamTypes{String}->new(); } if (@params == 1) { my $source = $params[0]; if (not defined $source or not ref $source) { # some value (string?). let's feed it to StringStreamWriter return $_streamTypes{String}->new($source); } if (UNIVERSAL::isa($source, "Data::ParseBinary::Stream::Writer")) { return $source; } die "Got unknown input to CreateStreamWriter"; } # @params > 1 my $source = pop @params; while (@params) { my $type = pop @params; if (not exists $_streamTypes{$type}) { die "CreateStreamWriter: Unrecognized type: $type"; } $source = $_streamTypes{$type}->new($source); } return $source; } sub DESTROY { my $self = shift; $self->Flush(); if ($self->can("disconnect")) { $self->disconnect(); } } package Data::ParseBinary::Stream::WrapperBase; # this is a nixin class for streams that will warp other streams sub _warping { my ($self, $sub_stream) = @_; if ($sub_stream->{is_warped}) { die "Wrapping Stream " . ref($self) . ": substream is already wraped!"; } $self->{ss} = $sub_stream; $sub_stream->{is_wraped} = 1; } sub ss { my $self = shift; return $self->{ss}; } sub disconnect { my ($self) = @_; $self->{ss}->{is_wraped} = 0; $self->{ss} = undef; } 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Core.pm0000755000000000000000000002147011127773332021364 0ustar rootrootuse strict; use warnings; package Data::ParseBinary::BaseConstruct; use Carp qw{confess}; our $DefaultPass; my $HOOK_BEFORE_ACTION = "HOOK_BEFORE_ACTION"; my $HOOK_AFTER_ACTION = "HOOK_AFTER_ACTION"; my $OBJECT_STACK = "OBJECT_STACK"; sub create { my ($class, $name) = @_; return bless { Name => $name }, $class; } sub _get_name { my $self = shift; return $self->{Name}; } sub parse { my ($self, $data) = @_; my $stream = Data::ParseBinary::Stream::Reader::CreateStreamReader($data); my $parser = Data::ParseBinary::Parser->new(); if (defined $Data::ParseBinary::print_debug_info) { my $tab = 0; my $before = sub { my ($loc_parser, $construct) = @_; print " " x $tab, "Parsing ", $construct->_pretty_name(), "\n"; $tab += 3; }; my $after = sub { $tab -= 3; }; $parser->{$HOOK_BEFORE_ACTION} = [$before]; $parser->{$HOOK_AFTER_ACTION} = [$after]; } $parser->push_stream($stream); my $results; eval { $results = $parser->_parse($self); }; return $results unless $@; confess $parser->_informative_exception($@); } sub _parse { my ($self, $parser, $stream) = @_; die "Bad Shmuel: sub __parse was not implemented for " . ref($self); } sub build { my ($self, $data, $source_stream) = @_; my $stream = Data::ParseBinary::Stream::Writer::CreateStreamWriter($source_stream); my $parser = Data::ParseBinary::Parser->new(); if (defined $Data::ParseBinary::print_debug_info) { my $tab = 0; my $before = sub { my ($loc_parser, $construct, $data) = @_; print " " x $tab, "Building ", _pretty_name($construct), "\n"; $tab += 3; }; my $after = sub { $tab -= 3; }; $parser->{$HOOK_BEFORE_ACTION} = [$before]; $parser->{$HOOK_AFTER_ACTION} = [$after]; } $parser->push_stream($stream); eval { $parser->_build($self, $data); }; confess $parser->_informative_exception($@) if $@; return $stream->Flush(); } sub _pretty_name { my ($self) = @_; my $name = $self->_get_name(); my $type = ref $self; $type =~ s/^Data::ParseBinary:://; $name ||= ""; return "$type $name"; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Bad Shmuel: sub _build was not implemented for " . ref($self); } sub _size_of { my ($self, $context) = @_; die "This Construct (".ref($self).") does not know his own size"; } package Data::ParseBinary::WrappingConstruct; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $subcon) = @_; my $self = $class->SUPER::create($subcon->_get_name()); $self->{subcon} = $subcon; return $self; } sub subcon { my $self = shift; return $self->{subcon}; } sub _parse { my ($self, $parser, $stream) = @_; return $parser->_parse($self->{subcon}); } sub _build { my ($self, $parser, $stream, $data) = @_; return $parser->_build($self->{subcon}, $data); } sub _size_of { my ($self, $context) = @_; return $self->{subcon}->_size_of($context); } package Data::ParseBinary::Adapter; our @ISA = qw{Data::ParseBinary::WrappingConstruct}; sub create { my ($class, $subcon, @params) = @_; my $self = $class->SUPER::create($subcon); $self->_init(@params); return $self; } sub _init { my ($self, @params) = @_; } sub _parse { my ($self, $parser, $stream) = @_; my $value = $self->SUPER::_parse($parser, $stream); my $tvalue = $self->_decode($value); return $tvalue; } sub _build { my ($self, $parser, $stream, $data) = @_; my $value = $self->_encode($data); $self->SUPER::_build($parser, $stream, $value); } sub _decode { my ($self, $value) = @_; die "An Adapter class should override the _decode sub"; #my $tvalue = transform($value); #return $tvalue; } sub _encode { my ($self, $tvalue) = @_; die "An Adapter class should override the _decode sub"; #my $value = transform($tvalue); #return $value; } package Data::ParseBinary::Validator; our @ISA = qw{Data::ParseBinary::Adapter}; sub _decode { my ($self, $value) = @_; die "Validator error at " . $self->_get_name() unless $self->_validate($value); return $value; } sub _encode { my ($self, $tvalue) = @_; die "Validator error at " . $self->_get_name() unless $self->_validate($tvalue); return $tvalue; } sub _validate { my ($self, $value) = @_; die "An Validator class should override the _validate sub"; } package Data::ParseBinary::Parser; my $EVALS = 'EVAL_MARKER'; sub new { my ($class) = @_; return bless {ctx=>[], obj=>undef, $EVALS=>[], $OBJECT_STACK=>[] }, $class; } sub obj { my $self = shift; return $self->{obj}; } sub set_obj { my ($self, $new_obj) = @_; $self->{obj} = $new_obj; } sub ctx { my ($self, $level) = @_; $level ||= 0; die "Parser: ctx level $level does not exists" if $level >= scalar @{ $self->{ctx} }; return $self->{ctx}->[$level]; } sub push_ctx { my ($self, $new_ctx) = @_; unshift @{ $self->{ctx} }, $new_ctx; } sub pop_ctx { my $self = shift; return shift @{ $self->{ctx} }; } sub push_stream { my ($self, $new_stream) = @_; unshift @{ $self->{streams} }, $new_stream; } sub pop_stream { my $self = shift; return shift @{ $self->{streams} }; } sub stream { my $self = shift; return $self->{streams}->[0]; } sub eval_enter { my ($self) = @_; my $streams_count = @{ $self->{streams} }; my $objects_count = @{ $self->{$OBJECT_STACK} }; my $eval_rec = { stream_count => $streams_count, objects_count => $objects_count }; push @{ $self->{$EVALS} }, $eval_rec; } sub eval_leave { my ($self) = @_; my $eval_rec = pop @{ $self->{$EVALS} }; my $streams_count = $eval_rec->{stream_count}; if ($streams_count < @{ $self->{streams} }) { splice( @{ $self->{streams} }, 0, @{ $self->{streams} } - $streams_count, ()); } my $objects_count = $eval_rec->{objects_count}; if ($objects_count < @{ $self->{$OBJECT_STACK} }) { splice( @{ $self->{$OBJECT_STACK} }, $objects_count, @{ $self->{$OBJECT_STACK} } - $objects_count, ()); } } sub _build { my ($self, $construct, $data) = @_; my $streams_count = @{ $self->{streams} }; push @{ $self->{$OBJECT_STACK} }, $construct; if (exists $self->{$HOOK_BEFORE_ACTION}) { foreach my $hba ( @{ $self->{$HOOK_BEFORE_ACTION} } ) { $hba->($self, $construct, $data); } } $construct->_build($self, $self->{streams}->[0], $data); if (exists $self->{$HOOK_AFTER_ACTION}) { foreach my $hba ( @{ $self->{$HOOK_AFTER_ACTION} } ) { $hba->($self, $construct, undef); } } pop @{ $self->{$OBJECT_STACK} }; if ($streams_count < @{ $self->{streams} }) { splice( @{ $self->{streams} }, 0, @{ $self->{streams} } - $streams_count, ()); } } sub _parse { my ($self, $construct) = @_; my $streams_count = @{ $self->{streams} }; push @{ $self->{$OBJECT_STACK} }, $construct; if (exists $self->{$HOOK_BEFORE_ACTION}) { foreach my $hba ( @{ $self->{$HOOK_BEFORE_ACTION} } ) { $hba->($self, $construct, undef); } } my $data = $construct->_parse($self, $self->{streams}->[0]); if (exists $self->{$HOOK_AFTER_ACTION}) { foreach my $hba ( @{ $self->{$HOOK_AFTER_ACTION} } ) { $hba->($self, $construct, $data); } } pop @{ $self->{$OBJECT_STACK} }; if ($streams_count < @{ $self->{streams} }) { splice( @{ $self->{streams} }, 0, @{ $self->{streams} } - $streams_count, ()); } return $data; } sub _informative_exception { my ($self, $msg) = @_; $msg =~ s/ at (.*)//; my $ex = "Got Exception $msg\n"; $ex .= "Streams location:\n"; my $ix = 1; foreach my $stream ( @{ $self->{streams} } ) { my $stream_ref = ref $stream; $stream_ref =~ s/^Data\:\:ParseBinary\:\:Stream\:\://; $ex .= "$ix: Stream " . $stream_ref . " in byte #" . $stream->tell() . "\n"; $ix++; } $ex .= "Constructs Stack:\n"; $ix = 1; foreach my $object (reverse @{ $self->{$OBJECT_STACK} }) { $ex .= "$ix: " . $object->_pretty_name() . "\n"; $ix++; } return $ex; } sub runCodeRef { my ($self, $coderef) = @_; if (not ($coderef and ref($coderef) and UNIVERSAL::isa($coderef, "CODE"))) { return $coderef; } local $_ = $self; return $coderef->(); } 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Graphics/0000755000000000000000000000000011535704017021664 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Graphics/PNG.pm0000755000000000000000000003161011525754712022660 0ustar rootrootpackage Data::ParseBinary::Graphics::PNG; use strict; use warnings; use Data::ParseBinary; use Data::ParseBinary qw{GreedyRange}; # Portable Network Graphics (PNG) file format # Official spec: http://www.w3.org/TR/PNG # # Original code contributed by Robin Munn (rmunn at pobox dot com) # (although the code has been extensively reorganized to meet Construct's # coding conventions) #=============================================================================== # utils #=============================================================================== sub Coord { my ($name, $field) = @_; $field ||= \&UBInt8; return Struct($name, &$field("x"), &$field("y"), ); } my $compression_method = Enum(UBInt8("compression_method"), deflate => 0, _default_ => $DefaultPass ); #=============================================================================== # 11.2.3: PLTE - Palette #=============================================================================== my $plte_info = Struct("plte_info", Value("num_entries", sub { $_->ctx(1)->{length} / 3}), Array(sub { $_->ctx->{num_entries} }, Struct("palette_entries", UBInt8("red"), UBInt8("green"), UBInt8("blue"), ), ), ); #=============================================================================== # 11.2.4: IDAT - Image data #=============================================================================== #my $idat_info = OnDemand( # Field("idat_info", sub { $_->ctx->{length} }), #); my $idat_info = Field("idat_info", sub { $_->ctx->{length} }); #=============================================================================== # 11.3.2.1: tRNS - Transparency #=============================================================================== my $trns_info = Switch("trns_info", sub { $_->ctx(1)->{image_header}->{color_type} }, { "greyscale" => Struct("data", UBInt16("grey_sample") ), "truecolor" => Struct("data", UBInt16("red_sample"), UBInt16("blue_sample"), UBInt16("green_sample"), ), "indexed" => Array(sub { $_->ctx->{length} }, UBInt8("alpha"), ), } ); #=============================================================================== # 11.3.3.1: cHRM - Primary chromacities and white point #=============================================================================== my $chrm_info = Struct("chrm_info", Coord("white_point", \&UBInt32), Coord("red", \&UBInt32), Coord("green", \&UBInt32), Coord("blue", \&UBInt32), ); #=============================================================================== # 11.3.3.2: gAMA - Image gamma #=============================================================================== my $gama_info = Struct("gama_info", UBInt32("gamma"), ); #=============================================================================== # 11.3.3.3: iCCP - Embedded ICC profile #=============================================================================== my $iccp_info = Struct("iccp_info", CString("name"), $compression_method, Field("compressed_profile", sub { $_->ctx(1)->{length} - (length( $_->ctx->{name}) + 2) } ), ); #=============================================================================== # 11.3.3.4: sBIT - Significant bits #=============================================================================== my $sbit_info = Switch("sbit_info", sub { $_->ctx(1)->{image_header}->{color_type} }, { "greyscale" => Struct("data", UBInt8("significant_grey_bits"), ), "truecolor" => Struct("data", UBInt8("significant_red_bits"), UBInt8("significant_green_bits"), UBInt8("significant_blue_bits"), ), "indexed" => Struct("data", UBInt8("significant_red_bits"), UBInt8("significant_green_bits"), UBInt8("significant_blue_bits"), ), "greywithalpha" => Struct("data", UBInt8("significant_grey_bits"), UBInt8("significant_alpha_bits"), ), "truewithalpha" => Struct("data", UBInt8("significant_red_bits"), UBInt8("significant_green_bits"), UBInt8("significant_blue_bits"), UBInt8("significant_alpha_bits"), ), } ); #=============================================================================== # 11.3.3.5: sRGB - Standard RPG color space #=============================================================================== my $srgb_info = Struct("srgb_info", Enum(UBInt8("rendering_intent"), perceptual => 0, relative_colorimetric => 1, saturation => 2, absolute_colorimetric => 3, _default_ => $DefaultPass, ), ); #=============================================================================== # 11.3.4.3: tEXt - Textual data #=============================================================================== my $text_info = Struct("text_info", CString("keyword"), Field("text", sub { $_->ctx(1)->{length} - (length($_->ctx->{keyword}) + 1) }), ); #=============================================================================== # 11.3.4.4: zTXt - Compressed textual data #=============================================================================== my $ztxt_info = Struct("ztxt_info", CString("keyword"), $compression_method, # OnDemand( Field("compressed_text", # As with iCCP, length is chunk length, minus length of # keyword, minus two: one byte for the null terminator, # and one byte for the compression method. sub { $_->ctx(1)->{length} - (length($_->ctx->{keyword}) + 2) }, ), # ), ); #=============================================================================== # 11.3.4.5: iTXt - International textual data #=============================================================================== my $itxt_info = Struct("itxt_info", CString("keyword"), UBInt8("compression_flag"), $compression_method, CString("language_tag"), CString("translated_keyword"), # OnDemand( Field("text", sub { $_->ctx(1)->{length} - (length($_->ctx->{keyword}) + length($_->ctx->{language_tag}) + length($_->ctx->{translated_keyword}) + 5) }, ), # ), ); #=============================================================================== # 11.3.5.1: bKGD - Background color #=============================================================================== my $bkgd_info = Switch("bkgd_info", sub { $_->ctx(1)->{image_header}->{color_type} }, { "greyscale" => Struct("data", UBInt16("background_greyscale_value"), Alias("grey", "background_greyscale_value"), ), "greywithalpha" => Struct("data", UBInt16("background_greyscale_value"), Alias("grey", "background_greyscale_value"), ), "truecolor" => Struct("data", UBInt16("background_red_value"), UBInt16("background_green_value"), UBInt16("background_blue_value"), Alias("red", "background_red_value"), Alias("green", "background_green_value"), Alias("blue", "background_blue_value"), ), "truewithalpha" => Struct("data", UBInt16("background_red_value"), UBInt16("background_green_value"), UBInt16("background_blue_value"), Alias("red", "background_red_value"), Alias("green", "background_green_value"), Alias("blue", "background_blue_value"), ), "indexed" => Struct("data", UBInt16("background_palette_index"), Alias("index", "background_palette_index"), ), } ); #=============================================================================== # 11.3.5.2: hIST - Image histogram #=============================================================================== my $hist_info = Array(sub { $_->ctx(1)->{length} / 2 }, UBInt16("frequency"), ); #=============================================================================== # 11.3.5.3: pHYs - Physical pixel dimensions #=============================================================================== my $phys_info = Struct("phys_info", UBInt32("pixels_per_unit_x"), UBInt32("pixels_per_unit_y"), Enum(UBInt8("unit"), unknown => 0, meter => 1, _default_ => $DefaultPass, ), ); #=============================================================================== # 11.3.5.4: sPLT - Suggested palette #=============================================================================== sub splt_info_data_length { my $entry_size; if ($_->ctx->{sample_depth} == 8) { $entry_size = 6; } else { $entry_size = 10; } return ($_->ctx(1)->{length} - length($_->ctx->{name}) - 2) / $entry_size; } my $splt_info = Struct("data", CString("name"), UBInt8("sample_depth"), Array(\&splt_info_data_length, IfThenElse("table", sub { $_->ctx->{sample_depth} == 8 }, # Sample depth 8 Struct("table", UBInt8("red"), UBInt8("green"), UBInt8("blue"), UBInt8("alpha"), UBInt16("frequency"), ), # Sample depth 16 Struct("table", UBInt16("red"), UBInt16("green"), UBInt16("blue"), UBInt16("alpha"), UBInt16("frequency"), ), ), ), ); #=============================================================================== # 11.3.6.1: tIME - Image last-modification time #=============================================================================== my $time_info = Struct("data", UBInt16("year"), UBInt8("month"), UBInt8("day"), UBInt8("hour"), UBInt8("minute"), UBInt8("second"), ); #=============================================================================== # chunks #=============================================================================== my $default_chunk_info = # OnDemand(HexDumpAdapter( Field(undef, sub {$_->ctx->{length} } # )) ); my $chunk = Struct("chunk", UBInt32("length"), String("type", 4), Switch("data", sub { $_->ctx->{type} }, { "PLTE" => $plte_info, "IEND" => $DefaultPass, "IDAT" => $idat_info, "tRNS" => $trns_info, "cHRM" => $chrm_info, "gAMA" => $gama_info, "iCCP" => $iccp_info, "sBIT" => $sbit_info, "sRGB" => $srgb_info, "tEXt" => $text_info, "zTXt" => $ztxt_info, "iTXt" => $itxt_info, "bKGD" => $bkgd_info, "hIST" => $hist_info, "pHYs" => $phys_info, "sPLT" => $splt_info, "tIME" => $time_info, }, default => $default_chunk_info, ), UBInt32("crc"), ); my $image_header_chunk = Struct("image_header", UBInt32("length"), Const(String("type", 4), "IHDR"), UBInt32("width"), UBInt32("height"), UBInt8("bit_depth"), Enum(UBInt8("color_type"), greyscale => 0, truecolor => 2, indexed => 3, greywithalpha => 4, truewithalpha => 6, _default_ => $DefaultPass, ), $compression_method, Enum(UBInt8("filter_method"), # "adaptive filtering with five basic filter types" adaptive5 => 0, _default_ => $DefaultPass, ), Enum(UBInt8("interlace_method"), none => 0, adam7 => 1, _default_ => $DefaultPass, ), UBInt32("crc"), ); #=============================================================================== # the complete PNG file #=============================================================================== our $png_parser = Struct("png", Magic("\x89PNG\r\n\x1a\n"), $image_header_chunk, GreedyRange($chunk), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($png_parser); 1; __END__ =head1 NAME Data::ParseBinary::Graphics::PNG =head1 SYNOPSIS use Data::ParseBinary::Graphics::PNG qw{$png_parser}; my $data = $png_parser->parse(CreateStreamReader(File => $fh)); Parses the binay PNG format, however it does not decompress the compressed data. Also, it does not compute / verify the CRC values. these actions are left to other layer in the program. This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Graphics/WMF.pm0000755000000000000000000000554511525756043022674 0ustar rootrootpackage Data::ParseBinary::Graphics::WMF; use strict; use warnings; use Data::ParseBinary; use Data::ParseBinary qw{Optional GreedyRange}; ##### # Windows Meta File ##### my $wmf_record = Struct("records", ULInt32("size"), # size in words, including the size, function and params Enum(ULInt16("function"), Arc => 0x0817, Chord => 0x0830, Ellipse => 0x0418, ExcludeClipRect => 0x0415, FloodFill => 0x0419, IntersectClipRect => 0x0416, LineTo => 0x0213, MoveTo => 0x0214, OffsetClipRgn => 0x0220, OffsetViewportOrg => 0x0211, OffsetWindowOrg => 0x020F, PatBlt => 0x061D, Pie => 0x081A, RealizePalette => 0x0035, Rectangle => 0x041B, ResizePalette => 0x0139, RestoreDC => 0x0127, RoundRect => 0x061C, SaveDC => 0x001E, ScaleViewportExt => 0x0412, ScaleWindowExt => 0x0400, SetBkColor => 0x0201, SetBkMode => 0x0102, SetMapMode => 0x0103, SetMapperFlags => 0x0231, SetPixel => 0x041F, SetPolyFillMode => 0x0106, SetROP2 => 0x0104, SetStretchBltMode => 0x0107, SetTextAlign => 0x012E, SetTextCharacterExtra => 0x0108, SetTextColor => 0x0209, SetTextJustification => 0x020A, SetViewportExt => 0x020E, SetViewportOrg => 0x020D, SetWindowExt => 0x020C, SetWindowOrg => 0x020B, _default_ => $DefaultPass, ), Array(sub { $_->ctx->{size} - 3 }, ULInt16("params")), ); my $wmf_placeable_header = Struct("placeable_header", Const(ULInt32("key"), 0x9AC6CDD7), ULInt16("handle"), SLInt16("left"), SLInt16("top"), SLInt16("right"), SLInt16("bottom"), ULInt16("units_per_inch"), Padding(4), ULInt16("checksum") ); our $wmf_parser = Struct("wmf_file", # --- optional placeable header --- Optional($wmf_placeable_header), # --- header --- Enum(ULInt16("type"), InMemory => 0, File => 1, ), Const(ULInt16("header_size"), 9), ULInt16("version"), ULInt32("size"), # file size is in words ULInt16("number_of_objects"), ULInt32("size_of_largest_record"), ULInt16("number_of_params"), # --- records --- GreedyRange($wmf_record) ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($wmf_parser); 1; __END__ =head1 NAME Data::ParseBinary::Graphics::WMF =head1 SYNOPSIS use Data::ParseBinary::Graphics::WMF qw{$wmf_parser}; my $data = $wmf_parser->parse(CreateStreamReader(File => $fh)); Parsing the WMF Graphic format files This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. No known issues =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Graphics/BMP.pm0000755000000000000000000000623311476440033022646 0ustar rootrootpackage Data::ParseBinary::Graphics::BMP; use strict; use warnings; use Data::ParseBinary; # Windows/OS2 Bitmap (BMP) #=============================================================================== # pixels: uncompressed #=============================================================================== sub UncompressedRows { my ($subcon, $align_to_byte) = @_; # argh! lines must be aligned to a 4-byte boundary, and bit-pixel # lines must be aligned to full bytes... my $line_pixels; if ($align_to_byte) { $line_pixels = Bitwise(Array(sub { $_->ctx(2)->{width} }, $subcon)); } else { $line_pixels = Array(sub { $_->ctx(2)->{width} }, $subcon); } return Array(sub { $_->ctx->{height} }, Aligned($line_pixels, 4)); } my $uncompressed_pixels = Switch("uncompressed", sub { $_->ctx->{bpp} }, { 1 => UncompressedRows(Bit("index"), 1), 4 => UncompressedRows(Nibble("index"), 1), 8 => UncompressedRows(Byte("index")), 24 => UncompressedRows(Sequence("rgb", Byte("red"), Byte("green"), Byte("blue"))), } ); #=============================================================================== # file structure #=============================================================================== our $bmp_parser = Struct("bitmap_file", # header Const(String("signature", 2), "BM"), ULInt32("file_size"), Padding(4), ULInt32("data_offset"), ULInt32("header_size"), Enum(Alias("version", "header_size"), v2 => 12, v3 => 40, v4 => 108, ), ULInt32("width"), ULInt32("height"), Value("number_of_pixels", sub { $_->ctx->{width} * $_->ctx->{height} }), ULInt16("planes"), ULInt16("bpp"), # bits per pixel Enum(ULInt32("compression"), Uncompressed => 0, RLE8 => 1, RLE4 => 2, Bitfields => 3, JPEG => 4, PNG => 5, ), ULInt32("image_data_size"), # in bytes ULInt32("horizontal_dpi"), ULInt32("vertical_dpi"), ULInt32("colors_used"), ULInt32("important_colors"), # palette (24 bit has no palette) If( sub { $_->ctx->{bpp} <= 8 }, Array( sub { 2 ** $_->ctx->{bpp} }, Struct("palette", Byte("blue"), Byte("green"), Byte("red"), Padding(1), ) ) ), # pixels Pointer( sub { $_->ctx->{data_offset} }, Switch("pixels", sub { $_->ctx->{compression} }, { "Uncompressed" => $uncompressed_pixels, } ), ), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($bmp_parser); 1; __END__ =head1 NAME Data::ParseBinary::Graphics::BMP =head1 SYNOPSIS use Data::ParseBinary::Graphics::BMP qw{$bmp_parser}; my $data = $bmp_parser->parse(CreateStreamReader(File => $fh)); Can parse / build any BMP file, (1, 4, 8 or 24 bit) as long as RLE is not used. This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Graphics/EMF.pm0000755000000000000000000001356711476440061022650 0ustar rootrootpackage Data::ParseBinary::Graphics::EMF; use strict; use warnings; use Data::ParseBinary; ## Enhanced Meta File my $record_type = Enum(ULInt32("record_type"), ABORTPATH => 68, ANGLEARC => 41, ARC => 45, ARCTO => 55, BEGINPATH => 59, BITBLT => 76, CHORD => 46, CLOSEFIGURE => 61, CREATEBRUSHINDIRECT => 39, CREATEDIBPATTERNBRUSHPT => 94, CREATEMONOBRUSH => 93, CREATEPALETTE => 49, CREATEPEN => 38, DELETEOBJECT => 40, ELLIPSE => 42, ENDPATH => 60, EOF => 14, EXCLUDECLIPRECT => 29, EXTCREATEFONTINDIRECTW => 82, EXTCREATEPEN => 95, EXTFLOODFILL => 53, EXTSELECTCLIPRGN => 75, EXTTEXTOUTA => 83, EXTTEXTOUTW => 84, FILLPATH => 62, FILLRGN => 71, FLATTENPATH => 65, FRAMERGN => 72, GDICOMMENT => 70, HEADER => 1, INTERSECTCLIPRECT => 30, INVERTRGN => 73, LINETO => 54, MASKBLT => 78, MODIFYWORLDTRANSFORM => 36, MOVETOEX => 27, OFFSETCLIPRGN => 26, PAINTRGN => 74, PIE => 47, PLGBLT => 79, POLYBEZIER => 2, POLYBEZIER16 => 85, POLYBEZIERTO => 5, POLYBEZIERTO16 => 88, POLYDRAW => 56, POLYDRAW16 => 92, POLYGON => 3, POLYGON16 => 86, POLYLINE => 4, POLYLINE16 => 87, POLYLINETO => 6, POLYLINETO16 => 89, POLYPOLYGON => 8, POLYPOLYGON16 => 91, POLYPOLYLINE => 7, POLYPOLYLINE16 => 90, POLYTEXTOUTA => 96, POLYTEXTOUTW => 97, REALIZEPALETTE => 52, RECTANGLE => 43, RESIZEPALETTE => 51, RESTOREDC => 34, ROUNDRECT => 44, SAVEDC => 33, SCALEVIEWPORTEXTEX => 31, SCALEWINDOWEXTEX => 32, SELECTCLIPPATH => 67, SELECTOBJECT => 37, SELECTPALETTE => 48, SETARCDIRECTION => 57, SETBKCOLOR => 25, SETBKMODE => 18, SETBRUSHORGEX => 13, SETCOLORADJUSTMENT => 23, SETDIBITSTODEVICE => 80, SETMAPMODE => 17, SETMAPPERFLAGS => 16, SETMETARGN => 28, SETMITERLIMIT => 58, SETPALETTEENTRIES => 50, SETPIXELV => 15, SETPOLYFILLMODE => 19, SETROP2 => 20, SETSTRETCHBLTMODE => 21, SETTEXTALIGN => 22, SETTEXTCOLOR => 24, SETVIEWPORTEXTEX => 11, SETVIEWPORTORGEX => 12, SETWINDOWEXTEX => 9, SETWINDOWORGEX => 10, SETWORLDTRANSFORM => 35, STRETCHBLT => 77, STRETCHDIBITS => 81, STROKEANDFILLPATH => 63, STROKEPATH => 64, WIDENPATH => 66, _default_ => $DefaultPass, ); my $generic_record = Struct("records", $record_type, ULInt32("record_size"), # Size of the record in bytes RoughUnion("params", # Parameters Field("raw", sub { $_->ctx(1)->{record_size} - 8 }), ExtractingAdapter( Struct("params", Array(sub { int(($_->ctx(1)->{record_size} - 8) / 4) }, ULInt32("params")), Padding(sub {$_->ctx(1)->{record_size} % 4}), ), "params"), ), ); my $header_record = Struct("header_record", Const($record_type, "HEADER"), ULInt32("record_size"), # Size of the record in bytes SLInt32("bounds_left"), # Left inclusive bounds SLInt32("bounds_right"), # Right inclusive bounds SLInt32("bounds_top"), # Top inclusive bounds SLInt32("bounds_bottom"), # Bottom inclusive bounds SLInt32("frame_left"), # Left side of inclusive picture frame SLInt32("frame_right"), # Right side of inclusive picture frame SLInt32("frame_top"), # Top side of inclusive picture frame SLInt32("frame_bottom"), # Bottom side of inclusive picture frame Const(ULInt32("signature"), 0x464D4520), ULInt32("version"), # Version of the metafile ULInt32("size"), # Size of the metafile in bytes ULInt32("num_of_records"), # Number of records in the metafile ULInt16("num_of_handles"), # Number of handles in the handle table Padding(2), ULInt32("description_size"), # Size of description string in WORDs ULInt32("description_offset"), # Offset of description string in metafile ULInt32("num_of_palette_entries"), # Number of color palette entries SLInt32("device_width_pixels"), # Width of reference device in pixels SLInt32("device_height_pixels"), # Height of reference device in pixels SLInt32("device_width_mm"), # Width of reference device in millimeters SLInt32("device_height_mm"), # Height of reference device in millimeters # description string If( sub {$_->ctx->{description_offset} != 0 and $_->ctx->{description_size} != 0}, Pointer(sub { $_->ctx->{description_offset} }, String("description", sub { $_->ctx->{description_size} }, encoding => 'UTF-16LE' ) #StringAdapter( # Array(sub { $_->ctx->{description_size} }, # Field("description", 2) # ) #) ), ), # padding up to end of record Padding(sub { $_->ctx->{record_size} - 88 }), ); our $emf_parser = Struct("emf_file", $header_record, Array(sub { $_->ctx->{header_record}->{num_of_records} - 1 }, $generic_record ), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($emf_parser); 1; __END__ =head1 NAME Data::ParseBinary::Graphics::EMF =head1 SYNOPSIS use Data::ParseBinary::Graphics::EMF qw{$emf_parser}; my $data = $emf_parser->parse(CreateStreamReader(File => $fh)); This parser just do not work on my example file. Have to take a look on it. This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Data/0000755000000000000000000000000011535704017020775 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Data/Netflow.pm0000755000000000000000000000406711476437647023003 0ustar rootrootpackage Data::ParseBinary::Data::Netflow; use strict; use warnings; use Data::ParseBinary; our $netflow_v5_parser = Struct("nfv5_header", Const(UBInt16("version"), 5), UBInt16("count"), UBInt32("sys_uptime"), UBInt32("unix_secs"), UBInt32("unix_nsecs"), UBInt32("flow_seq"), UBInt8("engine_type"), UBInt8("engine_id"), Padding(2), Array(sub { $_->ctx->{count} }, Struct("nfv5_record", Data::ParseBinary::lib::DataNetflow::IPAddr->create( UBInt32("src_addr") ), Data::ParseBinary::lib::DataNetflow::IPAddr->create( UBInt32("dst_addr") ), Data::ParseBinary::lib::DataNetflow::IPAddr->create( UBInt32("next_hop") ), UBInt16("i_ifx"), UBInt16("o_ifx"), UBInt32("packets"), UBInt32("octets"), UBInt32("first"), UBInt32("last"), UBInt16("s_port"), UBInt16("d_port"), Padding(1), UBInt8("flags"), UBInt8("prot"), UBInt8("tos"), UBInt16("src_as"), UBInt16("dst_as"), UBInt8("src_mask"), UBInt8("dst_mask"), UBInt16("unused2")), ), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($netflow_v5_parser); package Data::ParseBinary::lib::DataNetflow::IPAddr; use Socket qw(inet_ntoa inet_aton); our @ISA; BEGIN { @ISA = qw{Data::ParseBinary::Adapter}; } sub _decode { my ($self, $value) = @_; return inet_ntoa(pack('N',$value)); } sub _encode { my ($self, $value) = @_; return sprintf("%d", unpack('N',inet_aton($value))); } 1; =head1 NAME Data::ParseBinary::Data::Netflow - Parsing Netflow PDU binary structures =head1 SYNOPSIS use Data::ParseBinary::Data::Netflow qw($netflow_v5_parser); $data = $netflow_v5_parser->parse(CreateStreamReader(File => $fh)); # If file contain multiple flows, parse them till EOF while () { last if eof($fh); $data = $netflow_v5_parser->parse(CreateStreamReader(File => $fh)); } =head1 CAVEAT As for this moment version 5 format is supported only. Read files only in network byte order (BE). This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. =cutData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Data/Cap.pm0000755000000000000000000000427211525756132022052 0ustar rootrootpackage Data::ParseBinary::Data::Cap; use strict; use warnings; use Data::ParseBinary; use Data::ParseBinary qw{OptionalGreedyRange}; #""" #tcpdump capture file #""" my $packet = Struct("packet", Data::ParseBinary::lib::DataCap::MicrosecAdapter->create( Sequence("time", ULInt32("time"), ULInt32("usec"), ) ), ULInt32("length"), Padding(4), Field("data", sub { $_->ctx->{length} }), ); our $data_cap_parser = Struct("cap_file", Padding(24), OptionalGreedyRange($packet), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($data_cap_parser); package Data::ParseBinary::lib::DataCap::MicrosecAdapter; our @ISA; BEGIN { @ISA = qw{Data::ParseBinary::Adapter}; } sub _decode { my ($self, $value) = @_; return sprintf("%d.%06d", @$value) } sub _encode { my ($self, $tvalue) = @_; if ( index($tvalue, ".") >= 0 ) { my ($sec, $usec) = $tvalue =~ /^(\d+)\.(\d*)$/; if (length($usec) > 6) { $usec = substr($usec, 0, 6); } else { $usec .= "0" x (6 - length($usec)); } return [$sec, $usec]; } else { return [$tvalue, 0]; } } #def _decode(self, obj, context): # return datetime.fromtimestamp(obj[0] + (obj[1] / 1000000.0)) #def _encode(self, obj, context): # offset = time.mktime(*obj.timetuple()) # sec = int(offset) # usec = (offset - sec) * 1000000 # return (sec, usec) 1; __END__ =head1 NAME Data::ParseBinary::Data::Cap - Parsing "tcpdump capture file" =head1 SYNOPSIS use Data::ParseBinary::Data::Cap qw{$data_cap_parser}; my $data = $data_cap_parser->parse(CreateStreamReader(File => $fh)); Parsing "tcpdump capture file", whatever it is. Please note that this parser have a lot of white space. (paddings) So when I rebuild the file, the padded area is zeroed, and the re-created file does not match the original file. I don't know if the recreated file is valid. This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Stream/0000755000000000000000000000000011535704017021357 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Stream/Wrapper.pm0000755000000000000000000000252611050630254023336 0ustar rootrootuse strict; use warnings; package Data::ParseBinary::Stream::WrapperReader; our @ISA = qw{Data::ParseBinary::Stream::Reader Data::ParseBinary::Stream::WrapperBase}; __PACKAGE__->_registerStreamType("Wrap"); sub new { my ($class, $sub_stream) = @_; my $self = bless { }, $class; $self->_warping($sub_stream); return $self; } sub ReadBytes { my $self = shift; $self->{ss}->ReadBytes(@_); } sub ReadBits { my $self = shift; $self->{ss}->ReadBits(@_); } sub isBitStream { my $self = shift; $self->{ss}->isBitStream(@_); } sub seek { my $self = shift; $self->{ss}->seek(@_); } sub tell { my $self = shift; $self->{ss}->tell(@_); } package Data::ParseBinary::Stream::WrapperWriter; our @ISA = qw{Data::ParseBinary::Stream::Writer Data::ParseBinary::Stream::WrapperBase}; __PACKAGE__->_registerStreamType("Wrap"); sub new { my ($class, $sub_stream) = @_; my $self = bless { }, $class; $self->_warping($sub_stream); return $self; } sub WriteBytes { my $self = shift; $self->{ss}->WriteBytes(@_); } sub WriteBits { my $self = shift; $self->{ss}->WriteBits(@_); } sub Flush { my $self = shift; return $self->{ss} } sub isBitStream { my $self = shift; $self->{ss}->isBitStream(@_); } sub seek { my $self = shift; $self->{ss}->seek(@_); } sub tell { my $self = shift; $self->{ss}->tell(@_); } 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Stream/File.pm0000755000000000000000000000313711060220234022566 0ustar rootrootuse strict; use warnings; package Data::ParseBinary::Stream::FileReader; our @ISA = qw{Data::ParseBinary::Stream::Reader}; __PACKAGE__->_registerStreamType("File"); sub new { my ($class, $fh) = @_; my $self = { handle => $fh, }; return bless $self, $class; } sub ReadBytes { my ($self, $count) = @_; my $buf = ''; while ((my $buf_len = length($buf)) < $count) { my $bytes_read = read($self->{handle}, $buf, $count - $buf_len, $buf_len); die "Error: End of file" if $bytes_read == 0; } return $buf; } sub ReadBits { my ($self, $bitcount) = @_; return $self->_readBitsForByteStream($bitcount); } sub tell { my $self = shift; return CORE::tell($self->{handle}); } sub seek { my ($self, $newpos) = @_; CORE::seek($self->{handle}, $newpos, 0); } sub isBitStream { return 0 }; package Data::ParseBinary::Stream::FileWriter; our @ISA = qw{Data::ParseBinary::Stream::Writer}; __PACKAGE__->_registerStreamType("File"); sub new { my ($class, $fh) = @_; my $self = { handle => $fh, }; return bless $self, $class; } sub WriteBytes { my ($self, $data) = @_; print { $self->{handle} } $data; } sub WriteBits { my ($self, $bitdata) = @_; return $self->_writeBitsForByteStream($bitdata); } sub tell { my $self = shift; return CORE::tell($self->{handle}); } sub seek { my ($self, $newpos) = @_; CORE::seek($self->{handle}, $newpos, 0); } sub Flush { my $self = shift; } sub isBitStream { return 0 }; 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Stream/StringBuffer.pm0000755000000000000000000000333611050630344024316 0ustar rootrootuse strict; use warnings; package Data::ParseBinary::Stream::StringBufferReader; our @ISA = qw{Data::ParseBinary::Stream::StringRefReader Data::ParseBinary::Stream::WrapperBase}; __PACKAGE__->_registerStreamType("StringBuffer"); sub new { my ($class, $sub_stream) = @_; my $string = ''; my $self = $class->SUPER::new(\$string); $self->_warping($sub_stream); return $self; } sub ReadBytes { my ($self, $count) = @_; if ($self->{location} + $count > $self->{length}) { my $more_needed = $count - ($self->{length} - $self->{location}); my $new_bytes = $self->{ss}->ReadBytes($more_needed); ${ $self->{data} } .= $new_bytes; $self->{length} += $more_needed; } return $self->SUPER::ReadBytes($count); } sub seek { my ($self, $newpos) = @_; if ($newpos > $self->{length}) { my $more_needed = $newpos - $self->{length}; my $new_bytes = $self->{ss}->ReadBytes($more_needed); ${ $self->{data} } .= $new_bytes; $self->{length} += $more_needed; } $self->SUPER::seek($newpos); } package Data::ParseBinary::Stream::StringBufferWriter; our @ISA = qw{Data::ParseBinary::Stream::StringRefWriter Data::ParseBinary::Stream::WrapperBase}; __PACKAGE__->_registerStreamType("StringBuffer"); sub new { my ($class, $sub_stream) = @_; my $source = ''; my $self = $class->SUPER::new(\$source); $self->_warping($sub_stream); return $self; } sub Flush { my $self = shift; my $data = $self->SUPER::Flush(); $self->{ss}->WriteBytes($$data); my $empty_string = ''; $self->{data} = \$empty_string; $self->{offset} = 0; return $self->{ss}->Flush(); } 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Stream/String.pm0000755000000000000000000000611411044433540023163 0ustar rootrootuse strict; use warnings; package Data::ParseBinary::Stream::StringRefReader; our @ISA = qw{Data::ParseBinary::Stream::Reader}; __PACKAGE__->_registerStreamType("StringRef"); sub new { my ($class, $stringref) = @_; my $self = { data => $stringref, location => 0, length => length($$stringref), }; return bless $self, $class; } sub ReadBytes { my ($self, $count) = @_; die "not enought bytes in stream" if $self->{location} + $count > $self->{length}; my $data = substr(${ $self->{data} }, $self->{location}, $count); $self->{location} += $count; return $data; } sub ReadBits { my ($self, $bitcount) = @_; return $self->_readBitsForByteStream($bitcount); } sub tell { my $self = shift; return $self->{location}; } sub seek { my ($self, $newpos) = @_; die "can not seek past string's end" if $newpos > $self->{length}; $self->{location} = $newpos; } sub isBitStream { return 0 }; package Data::ParseBinary::Stream::StringReader; our @ISA = qw{Data::ParseBinary::Stream::StringRefReader}; __PACKAGE__->_registerStreamType("String"); sub new { my ($class, $string) = @_; return $class->SUPER::new(\$string); } package Data::ParseBinary::Stream::StringRefWriter; our @ISA = qw{Data::ParseBinary::Stream::Writer}; __PACKAGE__->_registerStreamType("StringRef"); sub new { my ($class, $source) = @_; if (not defined $source) { my $data = ''; $source = \$data; } my $self = { data => $source, offset => 0, # minus bytes from the end }; return bless $self, $class; } sub tell { my $self = shift; return length(${ $self->{data} }) - $self->{offset}; } sub seek { my ($self, $newpos) = @_; if ($newpos > length(${ $self->{data} })) { $self->{offset} = 0; ${ $self->{data} } .= "\0" x ($newpos - length(${ $self->{data} })) } else { $self->{offset} = length(${ $self->{data} }) - $newpos; } } sub WriteBytes { my ($self, $data) = @_; if ($self->{offset} == 0) { ${ $self->{data} } .= $data; return length ${ $self->{data} }; } substr(${ $self->{data} }, -$self->{offset}, length($data), $data); if ($self->{offset} <= length($data)) { $self->{offset} = 0; } else { $self->{offset} = $self->{offset} - length($data); } return length(${ $self->{data} }) - $self->{offset}; } sub WriteBits { my ($self, $bitdata) = @_; return $self->_writeBitsForByteStream($bitdata); } sub Flush { my $self = shift; return $self->{data}; } sub isBitStream { return 0 }; package Data::ParseBinary::Stream::StringWriter; our @ISA = qw{Data::ParseBinary::Stream::StringRefWriter}; __PACKAGE__->_registerStreamType("String"); sub new { my ($class, $source) = @_; $source = '' unless defined $source; return $class->SUPER::new(\$source); } sub Flush { my $self = shift; my $data = $self->SUPER::Flush(); return $$data; } 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Stream/Bit.pm0000755000000000000000000001026411216677160022445 0ustar rootrootuse strict; use warnings; package Data::ParseBinary::Stream::BitReader; our @ISA = qw{Data::ParseBinary::Stream::Reader Data::ParseBinary::Stream::WrapperBase}; __PACKAGE__->_registerStreamType("Bit"); sub new { my ($class, $byteStream) = @_; my $self = bless { buffer => '' }, $class; $self->_warping($byteStream); return $self; } sub ReadBytes { my ($self, $count) = @_; return $self->_readBytesForBitStream($count); } sub ReadBits { my ($self, $bitcount) = @_; my $current = $self->{buffer}; my $moreBitsNeeded = $bitcount - length($current); $moreBitsNeeded = 0 if $moreBitsNeeded < 0; my $moreBytesNeeded = int($moreBitsNeeded / 8) + ($moreBitsNeeded % 8 ? 1 : 0); #print "BitStream: $bitcount bits requested, $moreBytesNeeded bytes read\n"; my $string = $self->{ss}->ReadBytes($moreBytesNeeded); $current .= unpack "B*", $string; my $data = substr($current, 0, $bitcount, ''); $self->{buffer} = $current; return $data; } sub tell { my $self = shift; #die "A bit stream is not seekable"; if ($self->{buffer}) { return "Bit ". (8 - length($self->{buffer})) } else { return "Bit 0"; } } sub seek { my ($self, $newpos) = @_; die "A bit stream is not seekable"; } sub isBitStream { return 1 }; package Data::ParseBinary::Stream::BitWriter; our @ISA = qw{Data::ParseBinary::Stream::Writer Data::ParseBinary::Stream::WrapperBase}; __PACKAGE__->_registerStreamType("Bit"); sub new { my ($class, $byteStream) = @_; my $self = bless { buffer => '' }, $class; $self->_warping($byteStream); return $self; } sub WriteBytes { my ($self, $data) = @_; return $self->_writeBytesForBitStream($data); } sub WriteBits { my ($self, $bitdata) = @_; my $current = $self->{buffer}; my $new_buffer = $current . $bitdata; my $numof_bytesToWrite = int(length($new_buffer) / 8); my $bytesToWrite = substr($new_buffer, 0, $numof_bytesToWrite * 8, ''); my $binaryToWrite = pack "B".($numof_bytesToWrite * 8), $bytesToWrite; $self->{buffer} = $new_buffer; return $self->{ss}->WriteBytes($binaryToWrite); } sub Flush { my $self = shift; my $write_size = (-length($self->{buffer})) % 8; $self->WriteBits('0'x$write_size); return $self->{ss}->Flush(); } sub tell { my $self = shift; return "Bit ". length($self->{buffer}); #die "A bit stream is not seekable"; } sub seek { my ($self, $newpos) = @_; die "A bit stream is not seekable"; } sub isBitStream { return 1 }; package Data::ParseBinary::Stream::ReversedBitStreamReader; our @ISA = qw{Data::ParseBinary::Stream::BitReader}; __PACKAGE__->_registerStreamType("ReversedBit"); sub ReadBits { my ($self, $bitcount) = @_; my $current = $self->{buffer}; my $moreBitsNeeded = $bitcount - length($current); if ($moreBitsNeeded > 0) { my $moreBytesNeeded = int($moreBitsNeeded / 8) + ($moreBitsNeeded % 8 ? 1 : 0); my $string = $self->{ss}->ReadBytes($moreBytesNeeded); $string = join '', reverse split '', $string if $moreBytesNeeded > 1; $current = unpack("B*", $string) . $current; } my $data = substr($current, -$bitcount, $bitcount, ''); $data = join '', reverse split '', $data if length($data) > 1; $self->{buffer} = $current; return $data; } package Data::ParseBinary::Stream::ReversedBitStreamWriter; our @ISA = qw{Data::ParseBinary::Stream::BitWriter}; __PACKAGE__->_registerStreamType("ReversedBit"); sub WriteBits { my ($self, $bitdata) = @_; $bitdata = join '', reverse split '', $bitdata if length($bitdata) > 1; $self->{buffer} = $bitdata . $self->{buffer}; my $numof_bytesToWrite = int(length($self->{buffer}) / 8); my $num_of_bits_to_cut = $numof_bytesToWrite * 8; my $bytesToWrite = substr($self->{buffer}, -$num_of_bits_to_cut, $num_of_bits_to_cut, ''); my $binaryToWrite = pack "B".($numof_bytesToWrite * 8), $bytesToWrite; $binaryToWrite = join '', reverse split '', $binaryToWrite if $numof_bytesToWrite > 1; return $self->{ss}->WriteBytes($binaryToWrite); } 1;Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/FileSystem/0000755000000000000000000000000011535704017022210 5ustar rootrootData-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/FileSystem/MBR.pm0000755000000000000000000000442111476437775023214 0ustar rootrootpackage Data::ParseBinary::FileSystem::MBR; use strict; use warnings; use Data::ParseBinary; #""" #Master Boot Record #The first sector on disk, contains the partition table, bootloader, et al. # #http://www.win.tue.nl/~aeb/partitions/partition_types-1.html #""" our $mbr_parser = Struct("mbr", # The first 440 (446) bytes are executable code that is loaded by the # BIOS to boot the system. we use HexDump so it would print out nicely. Bytes("bootloader_code", 440), # Optional disk signature. Array(4, UBInt8('optional_disk_signature')), # Usually Nulls; 0x0000. Padding(2), Array(4, Struct("partitions", Enum(Byte("state"), INACTIVE => 0x00, ACTIVE => 0x80, ), BitStruct("beginning", Octet("head"), BitField("sect", 6), BitField("cyl", 10), ), Enum(UBInt8("type"), 'Unused' => 0x00, 'FAT12' => 0x01, 'XENIX root fs' => 0x02, 'XENIX /usr' => 0x03, 'FAT16 old' => 0x04, 'Extended_DOS' => 0x05, 'FAT16' => 0x06, 'FAT32' => 0x0b, 'FAT32 (LBA)' => 0x0c, 'NTFS' => 0x07, 'FAT16 (LBA)' => 0x0e, 'LINUX_SWAP' => 0x82, 'LINUX_NATIVE' => 0x83, _default_ => $DefaultPass, ), BitStruct("ending", Octet("head"), BitField("sect", 6), BitField("cyl", 10), ), ULInt32("sector_offset"), # offset from MBR in sectors ULInt32("size"), # in sectors ) ), Magic("\x55\xAA"), ); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($mbr_parser); 1; __END__ =head1 NAME Data::ParseBinary::FileSystem::MBR - Parsing the partition table =head1 SYNOPSIS use Data::ParseBinary::FileSystem::MBR qw{$mbr_parser}; my $data = $mbr_parser->parse(CreateStreamReader(File => $fh)); Can parse the binary structure of the MBR. (that is the structure that tells your computer what partitions exists on the drive) Getting the data from there is your problem. This is a part of the Data::ParseBinary package, and is just one ready-made parser. please go to the main page for additional usage info. =cut Data-ParseBinary-0.31~dfsg/lib/Data/ParseBinary/Constructs.pm0000755000000000000000000006112311525762217022644 0ustar rootrootpackage Data::ParseBinary::RoughUnion; use strict; use warnings; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, @subcons) = @_; my $self = $class->SUPER::create($name); $self->{subcons} = \@subcons; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $hash = {}; $parser->push_ctx($hash); my $w_stream = Data::ParseBinary::Stream::StringBufferReader->new($stream); $parser->push_stream($w_stream); my $pos = $w_stream->tell(); foreach my $sub (@{ $self->{subcons} }) { my $name = $sub->_get_name(); my $value = $parser->_parse($sub); $w_stream->seek($pos); next unless defined $name; $hash->{$name} = $value; } $w_stream->ReadBytes($self->{size}); $parser->pop_ctx(); return $hash; } sub _union_build { my ($self, $parser, $string_stream, $data) = @_; my $field_found = 0; my $pos = $string_stream->tell(); foreach my $sub (@{ $self->{subcons} }) { my $name = $sub->_get_name(); next unless exists $data->{$name} and defined $data->{$name}; $parser->_build($sub, $data->{$name}); $string_stream->seek($pos); $field_found = 1; } return $field_found; } sub _build { my ($self, $parser, $stream, $data) = @_; my $s_stream = Data::ParseBinary::Stream::StringWriter->new(); $parser->push_stream($s_stream); my $field_found = $self->_union_build($parser, $s_stream, $data); die "Union build error: not found any data" unless $field_found; $parser->pop_stream(); $stream->WriteBytes($s_stream->Flush()); } package Data::ParseBinary::Union; our @ISA = qw{Data::ParseBinary::RoughUnion}; sub create { my ($class, $name, @subcons) = @_; my $self = $class->SUPER::create($name, @subcons); my $size = $subcons[0]->_size_of(); foreach my $sub (@subcons) { my $temp_size = $sub->_size_of(); $size = $temp_size if $temp_size > $size; } $self->{size} = $size; return $self; } sub _build { my ($self, $parser, $stream, $data) = @_; my $s_stream = Data::ParseBinary::Stream::StringWriter->new(); $parser->push_stream($s_stream); my $field_found = $self->_union_build($parser, $s_stream, $data); die "Union build error: not found any data" unless $field_found; $parser->pop_stream(); my $string = $s_stream->Flush(); if ($self->{size} > length($string)) { $string .= "\0" x ( $self->{size} - length($string) ); } $stream->WriteBytes($string); } sub _size_of { my ($self, $context) = @_; return $self->{size}; } package Data::ParseBinary::Select; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, @subconstructs) = @_; die "Empty Struct is illigal" unless @subconstructs; my $self = $class->SUPER::create(undef); $self->{subs} = \@subconstructs; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $orig_pos = $stream->tell(); my $upper_hash = $parser->ctx(); foreach my $sub (@{ $self->{subs} }) { $stream->seek($orig_pos); my $hash = {}; $parser->push_ctx($hash); $parser->eval_enter(); my $name = $sub->_get_name(); my $value; eval { $value = $parser->_parse($sub); }; $parser->eval_leave(); $parser->pop_ctx(); next if $@; $hash->{$name} = $value if defined $name; while (my ($key, $val) = each %$hash) { $upper_hash->{$key} = $val; } return; } die "Problem with Select: no matching option"; } sub _build { my ($self, $parser, $stream, $data) = @_; my $upper_hash = $parser->ctx(); foreach my $sub (@{ $self->{subs} }) { my $hash = { %$upper_hash }; my $inter_stream = Data::ParseBinary::Stream::StringWriter->new(); $parser->push_ctx($hash); $parser->push_stream($inter_stream); $parser->eval_enter(); my $name = $sub->_get_name(); eval { $parser->_build($sub, defined $name? $hash->{$name} : undef); }; $parser->eval_leave(); $parser->pop_stream(); $parser->pop_ctx(); next if $@; %$upper_hash = %$hash; $stream->WriteBytes($inter_stream->Flush()); return; } die "Problem with Select: no matching option"; } package Data::ParseBinary::Restream; our @ISA = qw{Data::ParseBinary::WrappingConstruct}; sub create { my ($class, $subcon, $stream_name) = @_; my $self = $class->SUPER::create($subcon); $self->{stream_name} = $stream_name; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $sub_stream = Data::ParseBinary::Stream::Reader::CreateStreamReader($self->{stream_name} => $stream); $parser->push_stream($sub_stream); return $parser->_parse($self->{subcon}); } sub _build { my ($self, $parser, $stream, $data) = @_; my $sub_stream = Data::ParseBinary::Stream::Writer::CreateStreamWriter($self->{stream_name} => Wrap => $stream); $parser->push_stream($sub_stream); $parser->_build($self->{subcon}, $data); } package Data::ParseBinary::ConditionalRestream; our @ISA = qw{Data::ParseBinary::Restream}; sub create { my ($class, $subcon, $stream_name, $condition) = @_; my $self = $class->SUPER::create($subcon, $stream_name); $self->{condition} = $condition; return $self; } sub _parse { my ($self, $parser, $stream) = @_; if ($parser->runCodeRef($self->{condition})) { return $self->SUPER::_parse($parser, $stream); } else { return $parser->_parse($self->{subcon}); } } sub _build { my ($self, $parser, $stream, $data) = @_; if ($parser->runCodeRef($self->{condition})) { $self->SUPER::_build($parser, $stream, $data); } else { $parser->_build($self->{subcon}, $data); } } package Data::ParseBinary::TunnelAdapter; our @ISA = qw{Data::ParseBinary::WrappingConstruct}; sub create { my ($class, $subcon, $inner_subcon) = @_; my $self = $class->SUPER::create($subcon); $self->{inner_subcon} = $inner_subcon; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $inter = $parser->_parse($self->{subcon}); my $inter_stream = Data::ParseBinary::StringStreamReader->new($inter); return $parser->_parse($self->{inner_subcon}); } sub _build { my ($self, $parser, $stream, $data) = @_; my $inter_stream = Data::ParseBinary::Stream::StringWriter->new(); $parser->push_stream($inter_stream); $parser->_build($self->{inner_subcon}, $data); $parser->pop_stream(); $parser->_build($self->{subcon}, $inter_stream->Flush()); } package Data::ParseBinary::Peek; our @ISA = qw{Data::ParseBinary::WrappingConstruct}; sub create { my ($class, $subcon, $distance) = @_; my $self = $class->SUPER::create($subcon); $self->{distance} = $distance || 0; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $pos = $stream->tell(); my $distance = $parser->runCodeRef($self->{distance}); $stream->seek($pos + $distance); my $res = $parser->_parse($self->{subcon}); $stream->seek($pos); return $res; } sub _build { my ($self, $parser, $stream, $data) = @_; # does nothing } sub _size_of { my ($self, $context) = @_; # the construct size is 0 return 0; } package Data::ParseBinary::Value; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $func) = @_; my $self = $class->SUPER::create($name); $self->{func} = $func; return $self; } sub _parse { my ($self, $parser, $stream) = @_; return $parser->runCodeRef($self->{func}); } sub _build { my ($self, $parser, $stream, $data) = @_; $parser->ctx->{$self->_get_name()} = $parser->runCodeRef($self->{func}); } sub _size_of { my ($self, $context) = @_; # the construct size is 0 return 0; } package Data::ParseBinary::LazyBound; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $boundfunc) = @_; my $self = $class->SUPER::create($name); $self->{bound} = undef; $self->{boundfunc} = $boundfunc; return $self; } sub _parse { my ($self, $parser, $stream) = @_; return $parser->_parse($parser->runCodeRef($self->{boundfunc})); } sub _build { my ($self, $parser, $stream, $data) = @_; return $parser->_build($parser->runCodeRef($self->{boundfunc}), $data); } package Data::ParseBinary::Terminator; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub _parse { my ($self, $parser, $stream) = @_; eval { $stream->ReadBytes(1) }; if (not $@) { die "Terminator expected end of stream"; } return; } sub _build { my ($self, $parser, $stream, $data) = @_; return; } sub _size_of { my ($self, $context) = @_; # the construct size is 0 return 0; } package Data::ParseBinary::NullConstruct; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub _parse { my ($self, $parser, $stream) = @_; return; } sub _build { my ($self, $parser, $stream, $data) = @_; return; } sub _size_of { my ($self, $context) = @_; # the construct size is 0 return 0; } package Data::ParseBinary::Pointer; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $posfunc, $subcon) = @_; my $self = $class->SUPER::create($subcon->_get_name()); $self->{subcon} = $subcon; $self->{posfunc} = $posfunc; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $newpos = $parser->runCodeRef($self->{posfunc}); my $origpos = $stream->tell(); $stream->seek($newpos); my $value = $parser->_parse($self->{subcon}); $stream->seek($origpos); return $value; } sub _build { my ($self, $parser, $stream, $data) = @_; my $newpos = $parser->runCodeRef($self->{posfunc}); my $origpos = $stream->tell(); $stream->seek($newpos); $parser->_build($self->{subcon}, $data); $stream->seek($origpos); } sub _size_of { my ($self, $context) = @_; # the construct size is 0 return 0; } package Data::ParseBinary::Switch; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $keyfunc, $cases, %params) = @_; die "Switch expects code ref as keyfunc" unless $keyfunc and ref($keyfunc) and UNIVERSAL::isa($keyfunc, "CODE"); die "Switch expects hash-ref as a list of cases" unless $cases and ref($cases) and UNIVERSAL::isa($cases, "HASH"); my $self = $class->SUPER::create($name); $self->{keyfunc} = $keyfunc; $self->{cases} = $cases; $self->{default} = $params{default}; $self->{default} = Data::ParseBinary::NullConstruct->create() if $self->{default} and $self->{default} == $Data::ParseBinary::BaseConstruct::DefaultPass; return $self; } sub _getCont { my ($self, $parser) = @_; my $key = $parser->runCodeRef($self->{keyfunc}); if (exists $self->{cases}->{$key}) { return $self->{cases}->{$key}; } if (defined $self->{default}) { return $self->{default}; } die "Error at Switch: got un-declared value, and no default was defined"; } sub _parse { my ($self, $parser, $stream) = @_; my $value = $self->_getCont($parser); return unless defined $value; return $parser->_parse($value); } sub _build { my ($self, $parser, $stream, $data) = @_; my $value = $self->_getCont($parser); return unless defined $value; return $parser->_build($value, $data); } sub _size_of { my ($self, $context) = @_; my $size = -1; foreach my $subcon (values %{ $self->{cases} }) { my $sub_size = $subcon->_size_of($context); if ($size == -1) { $size = $sub_size; } else { die "This Switch have dynamic size" unless $size == $sub_size; } } if ($self->{default}) { my $sub_size = $self->{default}->_size_of($context); die "This Switch have dynamic size" unless $size == $sub_size; } return $size; } package Data::ParseBinary::StaticField; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $len) = @_; my $self = $class->SUPER::create($name); $self->{len} = $len; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $data = $stream->ReadBytes($self->{len}); return $data; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Invalid Value" unless defined $data and not ref $data; $stream->WriteBytes($data); } sub _size_of { my ($self, $context) = @_; return $self->{len}; } package Data::ParseBinary::MetaField; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $coderef) = @_; die "MetaField $name: must have a coderef" unless ref($coderef) and UNIVERSAL::isa($coderef, "CODE"); my $self = $class->SUPER::create($name); $self->{code} = $coderef; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $len = $parser->runCodeRef($self->{code}); my $data = $stream->ReadBytes($len); return $data; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Invalid Value" unless defined $data and not ref $data; $stream->WriteBytes($data); } package Data::ParseBinary::BitField; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $length) = @_; my $self = $class->SUPER::create($name); $self->{length} = $length; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $data = $stream->ReadBits($self->{length}); my $pad_len = 32 - $self->{length}; my $parsed = unpack "N", pack "B32", ('0' x $pad_len) . $data; return $parsed; } sub _build { my ($self, $parser, $stream, $data) = @_; my $binaryString = unpack("B32", pack "N", $data); my $string = substr($binaryString, -$self->{length}, $self->{length}); $stream->WriteBits($string); } package Data::ParseBinary::ReversedBitField; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $length) = @_; my $self = $class->SUPER::create($name); $self->{length} = $length; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $data = $stream->ReadBits($self->{length}); $data = join '', reverse split '', $data; my $pad_len = 32 - $self->{length}; my $parsed = unpack "N", pack "B32", ('0' x $pad_len) . $data; return $parsed; } sub _build { my ($self, $parser, $stream, $data) = @_; my $binaryString = unpack("B32", pack "N", $data); my $string = substr($binaryString, -$self->{length}, $self->{length}); $string = join '', reverse split '', $string; $stream->WriteBits($string); } package Data::ParseBinary::Padding; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $count) = @_; my $self = $class->SUPER::create(undef); $self->{count_code} = $count; return $self; } sub _parse { my ($self, $parser, $stream) = @_; if ($stream->isBitStream()) { $stream->ReadBits($parser->runCodeRef($self->{count_code})); } else { $stream->ReadBytes($parser->runCodeRef($self->{count_code})); } } sub _build { my ($self, $parser, $stream, $data) = @_; if ($stream->isBitStream()) { $stream->WriteBits("0" x $parser->runCodeRef($self->{count_code})); } else { $stream->WriteBytes("\0" x $parser->runCodeRef($self->{count_code})); } } package Data::ParseBinary::RepeatUntil; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $coderef, $sub) = @_; die "Empty MetaArray is illigal" unless $sub and $coderef; die "MetaArray must have a sub-construct" unless ref $sub and UNIVERSAL::isa($sub, "Data::ParseBinary::BaseConstruct"); die "MetaArray must have a length code ref" unless ref $coderef and UNIVERSAL::isa($coderef, "CODE"); my $name =$sub->_get_name(); my $self = $class->SUPER::create($name); $self->{sub} = $sub; $self->{len_code} = $coderef; return $self; } sub _shouldStop { my ($self, $parser, $value) = @_; $parser->set_obj($value); my $ret = $parser->runCodeRef($self->{len_code}); $parser->set_obj(undef); return $ret; } sub _parse { my ($self, $parser, $stream) = @_; my $list = []; $parser->push_ctx($list); while (1) { my $value = $parser->_parse($self->{sub}); push @$list, $value; last if $self->_shouldStop($parser, $value); } $parser->pop_ctx(); return $list; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Invalid Sequence Value" unless defined $data and ref $data and UNIVERSAL::isa($data, "ARRAY"); $parser->push_ctx($data); for my $item (@$data) { $parser->_build($self->{sub}, $item); last if $self->_shouldStop($parser, $item); } $parser->pop_ctx(); } package Data::ParseBinary::MetaArray; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $coderef, $sub) = @_; die "Empty MetaArray is illigal" unless $sub and $coderef; die "MetaArray must have a sub-construct" unless ref $sub and UNIVERSAL::isa($sub, "Data::ParseBinary::BaseConstruct"); die "MetaArray must have a length code ref" unless ref $coderef and UNIVERSAL::isa($coderef, "CODE"); my $name =$sub->_get_name(); my $self = $class->SUPER::create($name); $self->{sub} = $sub; $self->{len_code} = $coderef; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $len = $parser->runCodeRef($self->{len_code}); my $list = []; $parser->push_ctx($list); for my $ix (1..$len) { my $value = $parser->_parse($self->{sub}); push @$list, $value; } $parser->pop_ctx(); return $list; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Invalid Sequence Value" unless defined $data and ref $data and UNIVERSAL::isa($data, "ARRAY"); my $len = $parser->runCodeRef($self->{len_code}); die "Invalid Sequence Length (length param is $len, actual input is ".scalar(@$data).")" if @$data != $len; $parser->push_ctx($data); for my $item (@$data) { $parser->_build($self->{sub}, $item); } $parser->pop_ctx(); } package Data::ParseBinary::Range; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $min, $max, $sub) = @_; die "Empty Struct is illigal" unless $sub; die "Repeater must have a sub-construct" unless ref $sub and UNIVERSAL::isa($sub, "Data::ParseBinary::BaseConstruct"); my $name =$sub->_get_name(); my $self = $class->SUPER::create($name); $self->{sub} = $sub; $self->{max} = $max; $self->{min} = $min; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $list = []; $parser->push_ctx($list); my $max = $self->{max}; if (defined $max) { for my $ix (1..$max) { my $value; eval { $value = $parser->_parse($self->{sub}); }; if ($@) { die $@ if $ix <= $self->{min}; last; } push @$list, $value; } } else { my $ix = 0; while (1) { $ix++; my $value; eval { $value = $parser->_parse($self->{sub}); }; if ($@) { die $@ if $ix <= $self->{min}; last; } push @$list, $value; } } $parser->pop_ctx(); return $list; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Invalid Sequence Value" unless defined $data and ref $data and UNIVERSAL::isa($data, "ARRAY"); die "Invalid Sequence Length (min)" if @$data < $self->{min}; die "Invalid Sequence Length (max)" if defined $self->{max} and @$data > $self->{max}; $parser->push_ctx($data); for my $item (@$data) { $parser->_build($self->{sub}, $item); } $parser->pop_ctx(); } package Data::ParseBinary::Sequence; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, @subconstructs) = @_; die "Empty Struct is illigal" unless @subconstructs; my $self = $class->SUPER::create($name); $self->{subs} = \@subconstructs; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $list = []; $parser->push_ctx($list); foreach my $sub (@{ $self->{subs} }) { my $name = $sub->_get_name(); my $value = $parser->_parse($sub); next unless defined $name; push @$list, $value; } $parser->pop_ctx(); return $list; } sub _build { my ($self, $parser, $stream, $data) = @_; my $subs_count = @{ $self->{subs} }; die "Invalid Sequence Value" unless defined $data and ref $data and UNIVERSAL::isa($data, "ARRAY"); die "Invalid Sequence Length" if @$data > $subs_count; $parser->push_ctx($data); for my $ix (0..$#$data) { my $sub = $self->{subs}->[$ix]; my $name = $sub->_get_name(); if (defined $name) { die "Invalid Sequence Length" if $ix >= $subs_count; $parser->_build($sub, $data->[$ix]); } else { $parser->_build($sub, undef); redo; } } $parser->pop_ctx(); } sub _size_of { my ($self, $context) = @_; my $size = 0; foreach my $sub (@{ $self->{subs} }) { $size += $sub->_size_of($context); } return $size; } package Data::ParseBinary::Struct; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, @subconstructs) = @_; die "Empty Struct is illigal" unless @subconstructs; my $self = $class->SUPER::create($name); $self->{subs} = \@subconstructs; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $hash = {}; $parser->push_ctx($hash); foreach my $sub (@{ $self->{subs} }) { my $name = $sub->_get_name(); my $value = $parser->_parse($sub); next unless defined $name; $hash->{$name} = $value; } $parser->pop_ctx(); return $hash; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Invalid Struct Value" unless defined $data and ref $data and UNIVERSAL::isa($data, "HASH"); $parser->push_ctx($data); foreach my $sub (@{ $self->{subs} }) { my $name = $sub->_get_name(); $parser->_build($sub, defined $name? $data->{$name} : undef); } $parser->pop_ctx(); } sub _size_of { my ($self, $context) = @_; my $size = 0; foreach my $sub (@{ $self->{subs} }) { $size += $sub->_size_of($context); } return $size; } package Data::ParseBinary::Primitive; our @ISA = qw{Data::ParseBinary::BaseConstruct}; sub create { my ($class, $name, $sizeof, $pack_param) = @_; my $self = $class->SUPER::create($name); $self->{sizeof} = $sizeof; $self->{pack_param} = $pack_param; return $self; } sub _parse { my ($self, $parser, $stream) = @_; my $data = $stream->ReadBytes($self->{sizeof}); my $number = unpack $self->{pack_param}, $data; return $number; } sub _build { my ($self, $parser, $stream, $data) = @_; die "Invalid Primitive Value" unless defined $data; # FIXME and not ref $data; my $string = pack $self->{pack_param}, $data; $stream->WriteBytes($string); } sub _size_of { my ($self, $context) = @_; return $self->{sizeof}; } package Data::ParseBinary::ReveresedPrimitive; our @ISA = qw{Data::ParseBinary::Primitive}; sub _parse { my ($self, $parser, $stream) = @_; my $data = $stream->ReadBytes($self->{sizeof}); my $r_data = join '', reverse split '', $data; my $number = unpack $self->{pack_param}, $r_data; return $number; } sub _build { my ($self, $parser, $stream, $data) = @_; my $string = pack $self->{pack_param}, $data; my $r_string = join '', reverse split '', $string; $stream->WriteBytes($r_string); } sub _size_of { my ($self, $context) = @_; return $self->{sizeof}; } 1;Data-ParseBinary-0.31~dfsg/META.yml0000755000000000000000000000115311535704021015535 0ustar rootroot--- #YAML:1.0 name: Data-ParseBinary version: 0.31 abstract: Yet Another parser for binary structures author: - Shmuel Fomberg license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Math::BigInt: 1.993 Test::More: 0.96 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Data-ParseBinary-0.31~dfsg/MANIFEST0000755000000000000000000000211311535704022015413 0ustar rootrootMakefile.PL MANIFEST Changes README lib/Data/ParseBinary.pm lib/Data/ParseBinary/Adapters.pm lib/Data/ParseBinary/Constructs.pm lib/Data/ParseBinary/Core.pm lib/Data/ParseBinary/Streams.pm lib/Data/ParseBinary/Stream/String.pm lib/Data/ParseBinary/Stream/StringBuffer.pm lib/Data/ParseBinary/Stream/Bit.pm lib/Data/ParseBinary/Stream/Wrapper.pm lib/Data/ParseBinary/Stream/File.pm lib/Data/ParseBinary/Data/Cap.pm lib/Data/ParseBinary/Data/Netflow.pm lib/Data/ParseBinary/Executable/ELF32.pm lib/Data/ParseBinary/Executable/PE32.pm lib/Data/ParseBinary/Graphics/WMF.pm lib/Data/ParseBinary/Graphics/PNG.pm lib/Data/ParseBinary/Graphics/BMP.pm lib/Data/ParseBinary/Graphics/EMF.pm lib/Data/ParseBinary/FileSystem/MBR.pm t/01various.t t/02streams.t t/03lib.t t/04encodings.t t/05bigint.t t/wmf1.wmf t/png1.png t/png2.png t/emf1.emf t/bitmapx1.bmp t/bitmapx4.bmp t/bitmapx8.bmp t/bitmapx24.bmp t/_ctypes_test.so t/notepad.exe t/python.exe t/sqlite3.dll t/netflowv5.pdu t/cap2.cap META.yml Module meta-data (added by MakeMaker) Data-ParseBinary-0.31~dfsg/Makefile.PL0000755000000000000000000000053211535700755016250 0ustar rootrootuse ExtUtils::MakeMaker; WriteMakefile( NAME => 'Data::ParseBinary', VERSION_FROM => 'lib/Data/ParseBinary.pm', ABSTRACT_FROM => 'lib/Data/ParseBinary.pm', AUTHOR => 'Shmuel Fomberg ', PREREQ_PM => { 'Math::BigInt' => 1.993, 'Test::More' => 0.96, }, );