view release on metacpan or  search on metacpan

lib/AnyEvent/PacketReader.pm  view on Meta::CPAN

package AnyEvent::PacketReader;

our $VERSION = '0.01';

use strict;
use warnings;
use 5.010;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(packet_reader);

use AnyEvent;
use Carp;
use Errno qw(EPIPE EBADMSG EMSGSIZE EINTR EAGAIN EWOULDBLOCK);

our $MAX_TOTAL_LENGTH = 1e6;

our $debug;

my %header_length = ( n => 2,
                      v => 2,
                      N => 4,
                      V => 4,
                      W => 1,
                      S => 2,
                      L => 4,
                      Q => 8 );

for my $dir (qw(> <)) {
    for my $t (qw(S L Q)) {
        $header_length{"$t$dir"} = $header_length{$t};
    }
}

my %short_templ = map { $_ => $_ } keys %header_length;
my %load_offset = %header_length;
my $good_packers = join '', keys %header_length;

use Data::Dumper;
$SIG{INT} = sub {
    print Data::Dumper->Dump([\%short_templ, \%header_length, \%load_offset], [qw(%short_templ %header_length %load_offset)]);
    exit 1;
};

sub packet_reader {
    my $cb = pop;
    my ($fh, $templ, $max_total_length) = @_;
    croak 'Usage: packet_reader($fh, [$templ, [$max_total_length,]] $callback)'
        unless defined $fh and defined $cb;

    $max_total_length ||= $MAX_TOTAL_LENGTH;
    my ($header_length, $load_offset, $short_templ);

    if (defined $templ) {
        unless (defined($short_templ = $short_templ{$templ})) {
            $debug and warn "PR: examining template '$templ'\n";
            my $load_offset;
            if ($templ =~ /^(x+)(\d*)/g) {
                $header_length = length($1) + (length $2 ? $2 - 1 : 0);
            }
            elsif ($templ =~ /^\@!(\d*)/g) {
                $header_length = (length $1 ? $1 : 1);
            }
            else {
                $header_length = 0;
            }

            $templ =~ /\G([$good_packers][<>]?)/go
                or croak "bad header template '$templ'";

            $header_length += ($header_length{$1} // die "Internal error: \$header_length{$1} is not defined");

            $short_templ = substr $templ, 0, pos($templ);


            if ($templ =~ /\G\@!(\d*)/g) {
                $load_offset =  (length $1 ? $1 : 1);
            }
            else {
                $load_offset = $header_length;
                if ($templ =~ /\G(x+)(\d*)/g) {
                    $load_offset += length $1 + (length $2 ? $2 - 1 : 0);
                }
            }

            $templ =~ /\G$/g or croak "bad header template '$templ'";

            $short_templ{$templ} = $short_templ;
            $header_length{$templ} = $header_length;
            $load_offset{$templ} = $load_offset;
            $debug and warn "PR: template '$templ' examined, header_length: $header_length, load_offset: $load_offset\n";
        }

        $header_length = $header_length{$templ};
        $load_offset = $load_offset{$templ};

    }
    else {
        $debug and warn "PR: defaulting to template 'N'\n";
        $templ = 'N';
        $header_length = 4;