package POE::Filter::LittleEndian; use strict; use warnings; use Carp qw{ croak carp cluck }; use constant FRAMING_BUFFER => 0; use constant EXPECTED_SIZE => 1; use constant EVENT_CODE => 2; #------------------------------------------------------------------------------ sub new { my $type = shift; if (@_) { carp "POE::Filter::LittleEndian does not support any arguments!\n" } my $self = bless [ '', undef, undef, ], $type; $self; } #------------------------------------------------------------------------------ sub get { my ($self, $stream) = @_; my @blocks; $self->[FRAMING_BUFFER] .= join '', @{$stream}; # we know what to expect, size wise if ( defined $self -> [EXPECTED_SIZE] ) { # if the length of the buffer is less than we had hoped for, exit. last if (length $self -> [FRAMING_BUFFER] < $self -> [EXPECTED_SIZE]); # read in as much as we can my $chunk = substr($self -> [FRAMING_BUFFER], 0, $self -> [EXPECTED_SIZE]); # and then zap it, because we've read it. substr($self -> [FRAMING_BUFFER], 0, $self -> [EXPECTED_SIZE]) = ''; # and now we need another LENGTH block so we zap this one... undef $self -> [EXPECTED_SIZE]; # and return to caller. push @blocks, $chunk; } # we dont know what to expect, this is a new packet. else { my $little_e = $self -> [FRAMING_BUFFER]; my ($length, $event) = unpack 'vv', $little_e; my $body; # tell our hackers what event they had. $self -> [EVENT_CODE] = $event; # lop off the event code and the length, the hacker has it in the object. if ($length and (length $little_e >= 4 + $length)) { $body = substr($little_e, 4, $length); } $self -> [FRAMING_BUFFER] = $body; $self -> [EXPECTED_SIZE] = $length; } return \@blocks; } #------------------------------------------------------------------------------ # 2001-07-27 RCC: The get_one() variant of get() allows Wheel::Xyz to # retrieve one filtered block at a time. This is necessary for filter # changing and proper input flow control. sub get_one_start { my ($self, $stream) = @_; $self->[FRAMING_BUFFER] .= join '', @$stream; } sub get_one { my $self = shift; if ( defined $self -> [EXPECTED_SIZE] ) { return [ ] if length($self->[FRAMING_BUFFER]) < $self->[EXPECTED_SIZE]; my $block = substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]); substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]) = ''; undef $self->[EXPECTED_SIZE]; return [ $block ]; } else { my $little_e = $self -> [FRAMING_BUFFER]; my ($length, $event) = unpack 'vv', $little_e; return [ ] unless ($length and $event); my $body; $self -> [EXPECTED_SIZE] = $length; if ($length and (length $little_e >= 4 + $length)) { $body = substr($little_e, 4, $length); } $self -> [EVENT_CODE] = $event; $self -> [FRAMING_BUFFER] = $body; return [ ] if length($self->[FRAMING_BUFFER]) < $self->[EXPECTED_SIZE]; my $block = substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]); substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]) = ''; undef $self->[EXPECTED_SIZE]; return [ $block ]; } return [ ]; # not sure why we'd get here, but best to be safe... } #------------------------------------------------------------------------------ sub put { my ($self, $blocks) = (@_); return $blocks; } #------------------------------------------------------------------------------ sub get_pending { my $self = shift; return undef unless length $self->[FRAMING_BUFFER]; return [ $self->[FRAMING_BUFFER] ]; } ############################################################################### 1; __END__