parse-wormedit: seperate parsing module Parse::Binary::Nested

[wormy.git] / Parse / Binary / Nested.pm

diff --git a/Parse/Binary/Nested.pm b/Parse/Binary/Nested.pm
new file mode 100644 (file)
index 0000000..db5e208
--- /dev/null
+++ b/Parse/Binary/Nested.pm
@@ -0,0 +1,94 @@
+package Parse::Binary::Nested;
+
+use strict;
+use warnings;
+
+use Carp;
+
+our $VERSION = '1.00';
+
+sub new {
+       my ($class, $format) = @_;
+       ref $format eq 'ARRAY'
+               or croak "Invalid Parse::Binary::Nested format: should be an array ref";
+       bless $format, $class;
+}
+
+sub template {
+       my ($self, $format) = @_;
+       # total (flattened) unpack template from nested format definitions
+       return join '', map {
+               my $value = $format->[-($_ << 1) - 1];
+               if (ref $value eq 'ARRAY') {
+                       my $count = $value->[0];
+                       $value = $self->template($value);
+                       $value = $count =~ s/^([*\d]+)// ? "$count($value)$1"
+                               : $count."X[$count]$count/($value)";
+               }
+               else {
+                       $value =~ s/^C(a)(\d+)/$1 . ($2 + 1)/e;  # length prefix
+               }
+               $value;
+       } reverse 0 .. ($#$format - 1) >> 1;
+}
+
+sub convert {
+       my ($self, $format, $data) = @_;
+       # map flat results into a named and nested hash
+       my %res;
+       while (my ($field, $template) = splice @$format, 0, 2) {
+               if (ref $template eq 'ARRAY') {
+                       my ($count, @subformat) = @$template;
+                       my $max = $count =~ s/^(\d+)// ? $1 : 0;
+                       $count = !$count ? $max
+                               : $count eq '*' ? $res{levelcount}->{total} : shift @$data;
+                       $res{$field}->[$_] = $self->convert([@subformat], $data) for 0 .. ($max || $count)-1;
+                       splice @{ $res{$field} }, $count if $max > $count;
+                       $res{$field} = $res{$field}->[0] if $max == 1;
+                       next;
+               }
+               elsif ($template =~ /^Ca/) {
+                       $data->[0] = unpack 'C/a', $data->[0];
+               }
+               $res{$field} = shift @$data;
+       }
+       return \%res;
+}
+
+sub unpackf {
+       my ($self, $input) = @_;
+       my @data = unpack $self->template($self), $input;
+       return $self->convert([@$self], \@data);
+}
+
+1;
+
+=head1 NAME
+
+Parse::Binary::Nested - Structured unpack
+
+=head1 SYNOPSIS
+
+       use Parse::Binary::Nested;
+       my $parser = Parser::Binary::Nested->new([
+               foos => [
+                       'C', # count
+                       message => 'Z*',
+                       period  => 'C',
+               ],
+               trail => 'a*',
+       ]);
+       
+       my $data = $parser->unpackf("\1foo\0.rest");
+       print $data->{foos}->[0]->{message};
+
+=head1 DESCRIPTION
+
+=head1 AUTHOR
+
+Mischa POSLAWSKY <perl@shiar.org>
+
+=head1 LICENSE
+
+GPL version 3.
+