File Coverage

blib/lib/Parse/Binary/Iterative.pm

Criterion	Covered	Total	%
statement	18	18	100.0
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	24	24	100.0

package Parse::Binary::Iterative;
use 5.006;
use strict;
no strict 'refs';
use warnings;
use Carp;
our $VERSION = '1.00';
use base qw(Class::Data::Inheritable Class::Accessor);
use UNIVERSAL::require;

__PACKAGE__->mk_accessors("parent");
__PACKAGE__->mk_classdata($_) for ("FORMAT", "init_done");
__PACKAGE__->init_done(0);
__PACKAGE__->FORMAT([ Data => "a*" ]);

sub new {
    my ($class, $data) = @_;
    $class->_init();
    my $self = bless { }, $class;

    # Now call all the readers in turn
    my @format = @{$class->FORMAT};
    while (my ($key, $val) = splice(@format, 0, 2)) {
        my $method = "read_$key";
        $self->$method($data);
    }
    return $self;
}

sub _init {
    my $class = shift;
    return if $class->init_done();
    $class->init_done(1);
    my @format = @{$class->FORMAT};
    while (my ($key, $val) = splice(@format, 0, 2)) {
        $class->mk_ro_accessors($key);
        $class->mk_reader($key, $val);
    }
}

sub mk_reader {
    my ($class, $key, $pattern) = @_;

    *{"${class}::read_".$key} = sub {
        my ($self, $data) = @_;
        my @things;
        if (ref $pattern) { # XXX We need to do stuff with @$pattern
            if (@{$pattern} == 2 and ref $pattern->[1] eq "CODE") {
                my $p1 = $pattern->[0];
                @things = $pattern->[1]->(
                    unpack($p1, $class->_extract($p1, $data))
                );
            } else {
                my $key_class = $key;
                $key_class =~ s/_/::/g; $key_class->require;
                @things = $key_class->new($data);
                $_->parent($self) for @things;
            }
        } else {
            @things = unpack($pattern, $class->_extract($pattern, $data))
        }
        $self->{$key} = @things == 1 ? $things[0] : \@things;
    }
}

sub _extract {
    my ($self, $pattern, $data) = @_;
    if ($pattern =~ /\*/) { local $/; my $x = <$data>; return $x };

    my $len = length(pack($pattern, 0));
    if (ref $data eq "SCALAR") {
        return substr($$data, 0, $len, "");
    } elsif (ref $data eq "GLOB" or UNIVERSAL::isa($data, "IO::Handle")) {
        my $buf;
        croak "Run out of data!" if !read(*$data, $buf, $len) == $len;
        return $buf;
    } else {
        croak "Can't read from data handle, don't know what it is";
    }
}
1;
__END__