package Parse::Binary::Nested;

use 5.010;
use strict;
use warnings;

use Carp;

our $VERSION = '1.02';

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/=(?:\d+|.)//g;  # hardcoded values
			$value =~ s{^C/(a)(\d+)}{$1 . ($2 + 1)}e;  # maximum length
		}
		$value;
	} reverse 0 .. ($#$format - 1) >> 1;
}

sub convert {
	my ($self, $format, $data, $pos) = @_;
	# map flat results into a named and nested hash
	my %res;
	$pos ||= \(my $_pos);
	while (my ($field, $template) = splice @$format, 0, 2) {
		if (ref $template eq 'ARRAY') {
			my ($count, @subformat) = @$template;
			$$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, $pos)
				for 0 .. ($max || $count)-1;
			splice @{ $res{$field} }, $count if $max > $count;
			$res{$field} = $res{$field}->[0] if $max == 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;
				}
			}
		}
	}
	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

Converts a string into a hash of values, just like C<unpack>
except that it allows you to name and nest the resulting elements.

Format declarations are simalar to C<pack> templates,
with the following additions:

=over

=item *

An array ref groups additional declarations,
with the first value specifying a repetition.  If this count is variable,
the resulting value will be an array ref of hashes.

	repeat => ['C', name => 'a*', value => 'S']

With a count of 1, it will return only a hash ref,
thereby simply grouping declarations:

	test_foo => 'C'
	test => [1, foo => 'C']

=item *

A template value of C<Ca$length> is recognised as a length-preceded string
with a constant (maximal) size, and will return only the string adjusted
to its length.
This behaviour is very similar to C<(C/a@x$length)>, except that it never reads
more than the given number of bytes.

=item *

Hardcoded values can be inserted using C<=$number> values.
This can for example be useful to retain forwards-compatibility:

	rows => ['C',
		type => '=1', # nothing read
		data => 'S',
	]
	
	rows => ['C',
		type => 'C',
		data => 'S',
	]

=back

=head1 AUTHOR

Mischa POSLAWSKY <perl@shiar.org>

=head1 LICENSE

GPL version 3.

