File Coverage

blib/lib/POE/Filter/Block.pm
Criterion Covered Total %
statement 82 82 100.0
branch 38 50 76.0
condition 3 3 100.0
subroutine 14 14 100.0
pod 5 5 100.0
total 142 154 92.2


line stmt bran cond sub pod time code
1             package POE::Filter::Block;
2              
3 4     4   644 use strict;
  4         7  
  4         150  
4 4     4   406 use POE::Filter;
  4         7  
  4         123  
5              
6 4     4   17 use vars qw($VERSION @ISA);
  4         9  
  4         244  
7             $VERSION = '1.366'; # NOTE - Should be #.### (three decimal places)
8             @ISA = qw(POE::Filter);
9              
10 4     4   17 use Carp qw(croak);
  4         5  
  4         539  
11              
12             sub FRAMING_BUFFER () { 0 }
13             sub BLOCK_SIZE () { 1 }
14             sub EXPECTED_SIZE () { 2 }
15             sub ENCODER () { 3 }
16             sub DECODER () { 4 }
17             sub MAX_LENGTH () { 5 }
18             sub MAX_BUFFER () { 6 }
19             sub FIRST_UNUSED () { 7 }
20              
21 4     4   414 use base 'Exporter';
  4         7  
  4         2269  
22             our @EXPORT_OK = qw( FIRST_UNUSED );
23              
24             #------------------------------------------------------------------------------
25              
26             sub _default_decoder {
27 48     48   43 my $stuff = shift;
28 48 100       194 unless ($$stuff =~ s/^(\d+)\0//s) {
29 20 50       36 warn length($1), " strange bytes removed from stream"
30             if $$stuff =~ s/^(\D+)//s;
31 20         36 return;
32             }
33 28         66 return $1;
34             }
35              
36             sub _default_encoder {
37 30     30   23 my $stuff = shift;
38 30         54 substr($$stuff, 0, 0) = length($$stuff) . "\0";
39 30         48 return;
40             }
41              
42             sub new {
43 30     30 1 9239 my $type = shift;
44 30 50       76 croak "$type must be given an even number of parameters" if @_ & 1;
45 30         61 my %params = @_;
46              
47 30         130 my $max_buffer = $type->__param_max( MaxBuffer => 512*1024*1024, \%params );
48              
49 28         32 my ($encoder, $decoder, $max_length);
50 28         44 my $block_size = delete $params{BlockSize};
51 28 100       48 if (defined $block_size) {
52 7 50       20 croak "$type doesn't support zero or negative block sizes"
53             if $block_size < 1;
54 7 50       19 croak "Can't use both LengthCodec and BlockSize at the same time"
55             if exists $params{LengthCodec};
56 7 50       26 croak "Can't use both MaxLength and BlockSize at the same time"
57             if exists $params{MaxLength};
58             }
59             else {
60 21         48 my $codec = delete $params{LengthCodec};
61 21 100       34 if ($codec) {
62 1 50       3 croak "LengthCodec must be an array reference"
63             unless ref($codec) eq "ARRAY";
64 1 50       3 croak "LengthCodec must contain two items"
65             unless @$codec == 2;
66 1         1 ($encoder, $decoder) = @$codec;
67 1 50       3 croak "LengthCodec encoder must be a code reference"
68             unless ref($encoder) eq "CODE";
69 1 50       2 croak "LengthCodec decoder must be a code reference"
70             unless ref($decoder) eq "CODE";
71             }
72             else {
73 20         24 $encoder = \&_default_encoder;
74 20         23 $decoder = \&_default_decoder;
75             }
76 21         70 $max_length = $type->__param_max( MaxLength => 64*1024*1024, \%params );
77 19 100       239 croak "MaxBuffer is not large enough for MaxLength blocks"
78             unless $max_buffer >= $max_length + length( $max_length ) + 1;
79             }
80              
81 25         48 delete @params{qw(MaxLength MaxBuffer LengthCode BlockSize)};
82 25 50       64 carp("$type ignores unknown parameters: ", join(', ', sort keys %params))
83             if scalar keys %params;
84              
85 25         94 my $self = bless [
86             '', # FRAMING_BUFFER
87             $block_size, # BLOCK_SIZE
88             undef, # EXPECTED_SIZE
89             $encoder, # ENCODER
90             $decoder, # DECODER
91             $max_length, # MAX_LENGTH
92             $max_buffer # MAX_BUFFER
93             ], $type;
94              
95 25         106 $self;
96             }
97              
98              
99             #------------------------------------------------------------------------------
100             # get() is inherited from POE::Filter.
101              
102             #------------------------------------------------------------------------------
103             # 2001-07-27 RCC: The get_one() variant of get() allows Wheel::Xyz to
104             # retrieve one filtered block at a time. This is necessary for filter
105             # changing and proper input flow control.
106              
107             sub get_one_start {
108 57     57 1 81 my ($self, $stream) = @_;
109 57         136 $self->[FRAMING_BUFFER] .= join '', @$stream;
110 57 100       181 die "Framing buffer exceeds the limit"
111             if $self->[MAX_BUFFER] < length( $self->[FRAMING_BUFFER] );
112             }
113              
114             sub get_one {
115 110     110 1 110 my $self = shift;
116              
117             # Need to check lengths in octets, not characters.
118 4 50   4   6 BEGIN { eval { require bytes } and bytes->import; }
  4         89  
119              
120             # If a block size is specified, then pull off a block of that many
121             # bytes.
122              
123 110 100       205 if (defined $self->[BLOCK_SIZE]) {
124 48 100       211 return [ ] unless length($self->[FRAMING_BUFFER]) >= $self->[BLOCK_SIZE];
125 26         62 my $block = substr($self->[FRAMING_BUFFER], 0, $self->[BLOCK_SIZE]);
126 26         54 substr($self->[FRAMING_BUFFER], 0, $self->[BLOCK_SIZE]) = '';
127 26         103 return [ $block ];
128             }
129              
130             # Otherwise we're doing the variable-length block thing. Look for a
131             # length marker, and then pull off a chunk of that length. Repeat.
132              
133 62 100       95 unless( defined($self->[EXPECTED_SIZE]) ) {
134 58         103 $self->[EXPECTED_SIZE] = $self->[DECODER]->(\$self->[FRAMING_BUFFER]);
135 58 100 100     239 die "Expected size of next block exceeds the limit"
136             if defined($self->[EXPECTED_SIZE]) and
137             $self->[EXPECTED_SIZE] > $self->[MAX_LENGTH];
138             }
139 61 100       93 if ( defined($self->[EXPECTED_SIZE]) ) {
140 36 100       61 return [ ] if length($self->[FRAMING_BUFFER]) < $self->[EXPECTED_SIZE];
141              
142             # Four-arg substr() would be better here, but it's not compatible
143             # with Perl as far back as we support.
144 32         49 my $block = substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]);
145 32         36 substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]) = '';
146 32         25 $self->[EXPECTED_SIZE] = undef;
147              
148 32         68 return [ $block ];
149             }
150              
151 25         44 return [ ];
152             }
153              
154             #------------------------------------------------------------------------------
155              
156             sub put {
157 42     42 1 3642 my ($self, $blocks) = @_;
158 42         47 my @raw;
159              
160             # Need to check lengths in octets, not characters.
161 4 50   4   831 BEGIN { eval { require bytes } and bytes->import; }
  4         37  
162              
163             # If a block size is specified, then just assume the put is right.
164             # This will cause quiet framing errors on the receiving side. Then
165             # again, we'll have quiet errors if the block sizes on both ends
166             # differ. Ah, well!
167              
168 42 100       107 if (defined $self->[BLOCK_SIZE]) {
169 16         66 @raw = join '', @$blocks;
170             }
171              
172             # No specified block size. Do the variable-length block thing. This
173             # steals a lot of Artur's code from the Reference filter.
174              
175             else {
176 26         35 @raw = @$blocks;
177 26         36 foreach (@raw) {
178 38         83 $self->[ENCODER]->(\$_);
179             }
180             }
181              
182 42         163 \@raw;
183             }
184              
185             #------------------------------------------------------------------------------
186              
187             sub get_pending {
188 12     12 1 379 my $self = shift;
189 12 100       34 return undef unless length $self->[FRAMING_BUFFER];
190 4         9 [ $self->[FRAMING_BUFFER] ];
191             }
192              
193             1;
194              
195             __END__