e4cacc3b759e9eda84e26c73fad7cd80b58bf335
[wormy.git] / Parse / Binary / Nested.pm
1 package Parse::Binary::Nested;
2
3 use strict;
4 use warnings;
5
6 use Carp;
7
8 our $VERSION = '1.00';
9
10 sub new {
11         my ($class, $format) = @_;
12         ref $format eq 'ARRAY'
13                 or croak "Invalid Parse::Binary::Nested format: should be an array ref";
14         bless $format, $class;
15 }
16
17 sub template {
18         my ($self, $format) = @_;
19         # total (flattened) unpack template from nested format definitions
20         return join '', map {
21                 my $value = $format->[-($_ << 1) - 1];
22                 if (ref $value eq 'ARRAY') {
23                         my $count = $value->[0];
24                         $value = $self->template($value);
25                         $value = $count =~ s/^([*\d]+)// ? "$count($value)$1"
26                                 : $count."X[$count]$count/($value)";
27                 }
28                 else {
29                         $value =~ s/^C(a)(\d+)/$1 . ($2 + 1)/e;  # length prefix
30                 }
31                 $value;
32         } reverse 0 .. ($#$format - 1) >> 1;
33 }
34
35 sub convert {
36         my ($self, $format, $data) = @_;
37         # map flat results into a named and nested hash
38         my %res;
39         while (my ($field, $template) = splice @$format, 0, 2) {
40                 if (ref $template eq 'ARRAY') {
41                         my ($count, @subformat) = @$template;
42                         my $max = $count =~ s/^(\d+)// ? $1 : 0;
43                         $count = !$count ? $max
44                                 : $count eq '*' ? $res{levelcount}->{total} : shift @$data;
45                         $res{$field}->[$_] = $self->convert([@subformat], $data) for 0 .. ($max || $count)-1;
46                         splice @{ $res{$field} }, $count if $max > $count;
47                         $res{$field} = $res{$field}->[0] if $max == 1;
48                         next;
49                 }
50                 elsif ($template =~ /^Ca/) {
51                         $data->[0] = unpack 'C/a', $data->[0];
52                 }
53                 elsif ($template =~ /^(?:[xX]\d*)*$/) {
54                         next;  # no values
55                 }
56                 $res{$field} = shift @$data;
57         }
58         return \%res;
59 }
60
61 sub unpackf {
62         my ($self, $input) = @_;
63         my @data = unpack $self->template($self), $input;
64         return $self->convert([@$self], \@data);
65 }
66
67 1;
68
69 =head1 NAME
70
71 Parse::Binary::Nested - Structured unpack
72
73 =head1 SYNOPSIS
74
75         use Parse::Binary::Nested;
76         my $parser = Parser::Binary::Nested->new([
77                 foos => [
78                         'C', # count
79                         message => 'Z*',
80                         period  => 'C',
81                 ],
82                 trail => 'a*',
83         ]);
84         
85         my $data = $parser->unpackf("\1foo\0.rest");
86         print $data->{foos}->[0]->{message};
87
88 =head1 DESCRIPTION
89
90 =head1 AUTHOR
91
92 Mischa POSLAWSKY <perl@shiar.org>
93
94 =head1 LICENSE
95
96 GPL version 3.
97