X-Git-Url: http://git.shiar.nl/wormy.git/blobdiff_plain/5f543f9395f3a885ee9b751e98d069b9ed54f885..f0508cdbda46583a7485903d195a3e19c60d0196:/Parse/Binary/Nested.pm

diff --git a/Parse/Binary/Nested.pm b/Parse/Binary/Nested.pm
index 872ccaa..6b74f64 100644
--- a/Parse/Binary/Nested.pm
+++ b/Parse/Binary/Nested.pm
@@ -1,72 +1,155 @@
 package Parse::Binary::Nested;
 
+use 5.010;
 use strict;
 use warnings;
 
 use Carp;
+use Exporter qw(import);
 
-our $VERSION = '1.01';
+our $VERSION = '1.10';
+our @EXPORT_OK = qw(unpackf);
 
 sub new {
 	my ($class, $format) = @_;
+	ref $format
+		or $format = [0 => $format];
 	ref $format eq 'ARRAY'
 		or croak "Invalid Parse::Binary::Nested format: should be an array ref";
-	bless $format, $class;
+	bless [$format, $class->template($format)], $class;
 }
 
 sub template {
 	my ($self, $format) = @_;
 	# total (flattened) unpack template from nested format definitions
-	return join '', map {
+	my $template = '';
+	@$format or return $template;
+	for (reverse 0 .. ($#$format - 1) >> 1) {
 		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)";
+			if ($count =~ /^\?/) {
+				$template .= 'a*';
+				last;
+			}
+			else {
+				$value = $self->template($value);
+				$value = $count =~ s/^([*\d]+)// ? "$count($value)$1"
+					: $count."X[$count]$count/($value)";
+			}
 		}
 		else {
-			$value =~ s/=\d*//g;  # hardcoded values
-			$value =~ s/^C(a)(\d+)/$1 . ($2 + 1)/e;  # length prefix
+			$value =~ s/=(?:\d+|.)//g;  # hardcoded values
+			$value =~ s{^C/(a)(\d+)}{$1 . ($2 + 1)}e;  # maximum length
 		}
-		$value;
-	} reverse 0 .. ($#$format - 1) >> 1;
+		$template .= $value;
+	}
+	return $template;
 }
 
 sub convert {
-	my ($self, $format, $data) = @_;
+	my ($self, $format, $data, $pos) = @_;
 	# map flat results into a named and nested hash
 	my %res;
-	while (my ($field, $template) = splice @$format, 0, 2) {
+	$pos ||= \(my $_pos = 0);
+	for (my $i = 0; $i < $#$format; $i += 2) {
+		my ($field, $template) = @$format[$i, $i+1];
 		if (ref $template eq 'ARRAY') {
 			my ($count, @subformat) = @$template;
+
+			if ($count =~ /^\?(\d+)/) {
+				# character-terminated group
+				my $endmark = chr $1;
+				my $iterate = ref($self)->new(\@subformat);
+				push @{ $iterate->[0] }, -pos => '=.';
+				my $subpos = 0;
+				while ($subpos < length $data->[0]) {
+					last if substr($data->[0], $subpos, 1) eq $endmark;
+					my $iterdata = $iterate->convert($iterate->[0], [
+						unpack $iterate->[1], substr($data->[0], $subpos)
+					]) or last;
+					$subpos += delete $iterdata->{-pos};
+					push @{ $res{$field} }, $iterdata;
+				}
+				$$pos += $subpos + 1;
+				@$data = unpack(
+					$self->template([ @$format[$i+2 .. $#$format] ]),
+					substr($data->[0], $subpos + 1)
+				) if $subpos < length $data->[0];
+				next;
+			}
+
+			$$pos++ if $count eq 'C';
 			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;
+			$res{$field}->[$_] = $self->convert(\@subformat, $data, $pos)
+				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];
-		}
-		elsif ($template =~ /^(?:[xX]\d*)*$/) {
-			next;  # no values
-		}
-		elsif ($template =~ /=(\d+)?/) {
-			$res{$field} = $1;
-			next;
+		else {
+			for (split m{(?![0-9*/])(?<![/=])}, $template) {
+				my ($type, $count) = m{^(\D+)(\d+)?$} or die 'unsupported';
+				my $mult = $count // 1;
+				given ($type) {
+					when (['c', 'C']) {
+						$$pos += $mult;
+					}
+					when ('x') {
+						$$pos += $mult;
+						next;
+					}
+					when (['b', 'B']) {
+						$$pos++;
+					}
+					when (['s', 'S', 'n', 'v']) {
+						$$pos += $mult * 2;
+					}
+					when (['a', 'A', 'Z', 'a*']) {
+						$$pos += length $data->[0];
+					}
+					when ('Z*') {
+						$$pos += $count // 1 + length $data->[0];
+					}
+					when (['C/a', 'C/A']) {
+						$$pos += 1 + ($count // length $data->[0]);
+						$data->[0] = unpack 'C/a', $data->[0] if defined $count;
+					}
+					when ('=') {
+						unshift @$data, $count;
+					}
+					when ('=.') {
+						unshift @$data, $$pos;
+					}
+					when ('X') {
+						$$pos -= $mult;
+						next;
+					}
+					default {
+						carp "Unrecognised template element '$type'";
+					}
+				}
+				if (defined $res{$field}) {
+					$res{$field} = [ $res{$field} ] unless ref $res{$field} eq 'ARRAY';
+					push @{ $res{$field} }, shift @$data;
+				}
+				else {
+					$res{$field} = shift @$data;
+				}
+			}
 		}
-		$res{$field} = shift @$data;
 	}
 	return \%res;
 }
 
 sub unpackf {
-	my ($self, $input) = @_;
-	my @data = unpack $self->template($self), $input;
-	return $self->convert([@$self], \@data);
+	my ($format, $input) = @_;
+	my $self = UNIVERSAL::isa($format, __PACKAGE__) ? $format
+		: __PACKAGE__->new($format);
+	my @data = unpack $self->[1], $input;
+	return $self->convert($self->[0], \@data);
 }
 
 1;
@@ -77,7 +160,9 @@ Parse::Binary::Nested - Structured unpack
 
 =head1 SYNOPSIS
 
-	use Parse::Binary::Nested;
+	use Parse::Binary::Nested qw(unpackf);
+	my $data = unpackf([message => 'Z*'], "hi\0");
+
 	my $parser = Parser::Binary::Nested->new([
 		foos => [
 			'C', # count
@@ -86,8 +171,7 @@ Parse::Binary::Nested - Structured unpack
 		],
 		trail => 'a*',
 	]);
-	
-	my $data = $parser->unpackf("\1foo\0.rest");
+	$data = $parser->unpackf("\1foo\0.rest");
 	print $data->{foos}->[0]->{message};
 
 =head1 DESCRIPTION