File Coverage

blib/lib/POE/Filter/Reference.pm
Criterion Covered Total %
statement 94 137 68.6
branch 28 62 45.1
condition 15 34 44.1
subroutine 16 19 84.2
pod 6 6 100.0
total 159 258 61.6


line stmt bran cond sub pod time code
1             # Filter::Reference partial copyright 1998 Artur Bergman
2             # . Partial copyright 1999 Philip Gwyn.
3              
4             package POE::Filter::Reference;
5              
6 15     15   5255 use strict;
  15         15  
  15         439  
7 15     15   358 use POE::Filter;
  15         28  
  15         271  
8              
9 15     15   46 use vars qw($VERSION @ISA);
  15         16  
  15         782  
10             $VERSION = '1.365'; # NOTE - Should be #.### (three decimal places)
11             @ISA = qw(POE::Filter);
12              
13 15     15   59 use Carp qw(carp croak confess);
  15         93  
  15         1801  
14              
15             sub BUFFER () { 0 }
16             sub FREEZE () { 1 }
17             sub THAW () { 2 }
18             sub COMPRESS () { 3 }
19             sub NO_FATALS () { 4 }
20             sub MAX_BUFFER () { 5 }
21             sub BAD_BUFFER () { 6 }
22             sub FIRST_UNUSED () { 7 }
23              
24 15     15   60 use base 'Exporter';
  15         14  
  15         1509  
25             our @EXPORT_OK = qw( FIRST_UNUSED );
26              
27             my %KNOWN_PARAMS = (
28             Compression => 1,
29             Serializer => 1,
30             NoFatals => 1,
31             MaxBuffer => 1
32             );
33              
34             #------------------------------------------------------------------------------
35             # Try to require one of the default freeze/thaw packages.
36 15     15   65 use vars qw( $DEF_FREEZER $DEF_FREEZE $DEF_THAW );
  15         30  
  15         2593  
37             BEGIN {
38 15     15   62 local $SIG{'__DIE__'} = 'DEFAULT';
39              
40 15         31 my @packages = qw(Storable FreezeThaw YAML);
41 15         29 foreach my $package (@packages) {
42 15         28 eval { require "$package.pm"; import $package (); };
  15         36152  
  15         52441  
43 15 50       85 if ($@) {
44 0         0 warn $@;
45 0         0 next;
46             }
47              
48             # Found a good freezer!
49 15         81 $DEF_FREEZER = $package;
50 15         43 last;
51             }
52 15 50       12299 die "Filter::Reference requires one of @packages" unless defined $DEF_FREEZER;
53             }
54              
55             # Some processing here
56             ($DEF_FREEZE, $DEF_THAW) = _get_methods($DEF_FREEZER);
57              
58             #------------------------------------------------------------------------------
59             # Try to acquire Compress::Zlib at run time.
60              
61             my $zlib_status = undef;
62             sub _include_zlib {
63 0     0   0 local $SIG{'__DIE__'} = 'DEFAULT';
64              
65 0 0       0 unless (defined $zlib_status) {
66 0         0 eval "use Compress::Zlib qw(compress uncompress)";
67 0 0       0 if ($@) {
68 0         0 $zlib_status = $@;
69             eval(
70 0         0 "sub compress { @_ }\n" .
71             "sub uncompress { @_ }"
72             );
73             }
74             else {
75 0         0 $zlib_status = '';
76             }
77             }
78              
79 0         0 $zlib_status;
80             }
81              
82             #------------------------------------------------------------------------------
83              
84             sub _get_methods {
85 29     29   39 my($freezer)=@_;
86 29   66     282 my $freeze=$freezer->can('nfreeze') || $freezer->can('freeze');
87 29         80 my $thaw=$freezer->can('thaw');
88 29 50 33     143 return unless $freeze and $thaw;
89 29         75 return ($freeze, $thaw);
90             }
91              
92             #------------------------------------------------------------------------------
93              
94             sub new
95             {
96 105     105 1 2760 my $type = shift;
97              
98             # Convert from old style to new style
99             # $l == 1
100             # ->new( undef ) => (Serializer => undef)
101             # ->new( $class ) => (Serializer => class)
102             # not defined $_[0]
103             # ->new( undef, 1 ) => (Serializer => undef, Compression => 1)
104             # ->new( undef, undef, 1 ) => (Serializer => undef, Compression => undef, NoFatals =>1)
105             # $l == 3
106             # ->new( $class, 1, 1 ) => (Serializer => undef, Compression => 1, NoFatals =>1)
107             # ($l <= 3 and not $KNOWN_PARAMS{$_[0]})
108             # ->new( $class, 1 )
109 105         135 my %params;
110 105         193 my $l = scalar @_;
111 105 50 66     900 if( $l == 1 or $l == 3 or not defined $_[0] or
      66        
      0        
      33        
112             ( $l<=3 and not $KNOWN_PARAMS{$_[0]}) ) {
113 105 50       275 if( 'HASH' eq ref $_[0] ) { # do we
114 0         0 %params = %{ $_[0] };
  0         0  
115             }
116             else {
117 105         564 %params = ( Serializer => $_[0],
118             Compression => $_[1],
119             NoFatals => $_[2]
120             );
121             }
122             }
123             else {
124 0 0 0     0 croak "$type requires an even number of parameters" if @_ and @_ & 1;
125 0         0 %params = @_;
126             }
127              
128 105         161 my($freeze, $thaw);
129 105         188 my $freezer = $params{Serializer};
130 105 100       202 unless (defined $freezer) {
131             # Okay, load the default one!
132 91         329 $freezer = $DEF_FREEZER;
133 91         152 $freeze = $DEF_FREEZE;
134 91         205 $thaw = $DEF_THAW;
135             }
136             else {
137             # What did we get?
138 14 50       25 if (ref $freezer) {
139             # It's an object, create an closure
140 0         0 my($freezetmp, $thawtmp) = _get_methods($freezer);
141 0     0   0 $freeze = sub { $freezetmp->($freezer, @_) };
  0         0  
142 0     0   0 $thaw = sub { $thawtmp-> ($freezer, @_) };
  0         0  
143             }
144             else {
145             # A package name?
146             # First, find out if the package has the necessary methods.
147 14         33 ($freeze, $thaw) = _get_methods($freezer);
148              
149             # If not, try to reload the module.
150 14 50 33     58 unless ($freeze and $thaw) {
151 0         0 my $path = $freezer;
152 0         0 $path =~ s{::}{/}g;
153 0         0 $path .= '.pm';
154              
155             # Force a reload if necessary. This is naive and can leak
156             # memory, so we only do it until we get the desired methods.
157 0         0 delete $INC{$path};
158              
159 0         0 eval {
160 0         0 local $^W = 0;
161 0         0 require $path;
162 0         0 $freezer->import();
163             };
164              
165 0 0       0 carp $@ if $@;
166 0         0 ($freeze, $thaw) = _get_methods($freezer);
167             }
168             }
169             }
170              
171             # Now get the methods we want
172 105 50       228 carp "$freezer doesn't have a freeze or nfreeze method" unless $freeze;
173 105 50       214 carp "$freezer doesn't have a thaw method" unless $thaw;
174              
175             # Should ->new() return undef() it if fails to find the methods it
176             # wants?
177 105 50 33     628 return unless $freeze and $thaw;
178              
179             # Maximum buffer
180 105         533 my $max_buffer = $type->__param_max( MaxBuffer => 512*1024*1024, \%params );
181              
182             # Compression
183 105   50     709 my $compression = $params{Compression}||0;
184 105 50       281 if ($compression) {
185 0         0 my $zlib_status = _include_zlib();
186 0 0       0 if ($zlib_status ne '') {
187 0         0 warn "Compress::Zlib load failed with error: $zlib_status\n";
188 0         0 carp "Filter::Reference compression option ignored";
189 0         0 $compression = 0;
190             }
191             }
192              
193             # No fatals
194 105   50     404 my $no_fatals = $params{NoFatals}||0;
195              
196 105         503 delete @params{ keys %KNOWN_PARAMS };
197 105 50       288 carp("$type ignores unknown parameters: ", join(', ', sort keys %params))
198             if scalar keys %params;
199              
200 105         472 my $self = bless [
201             '', # BUFFER
202             $freeze, # FREEZE
203             $thaw, # THAW
204             $compression, # COMPRESS
205             $no_fatals, # NO_FATALS
206             $max_buffer, # MAX_BUFFER
207             '' # BAD_BUFFER
208             ], $type;
209 105         492 $self;
210             }
211              
212             #------------------------------------------------------------------------------
213              
214             sub get {
215 1     1 1 5 my ($self, $stream) = @_;
216 1         1 my @return;
217              
218 1         3 $self->get_one_start($stream);
219 1         1 while (1) {
220 2         4 my $next = $self->get_one();
221 2 100       24 last unless @$next;
222 1         3 push @return, @$next;
223             }
224              
225 1         3 return \@return;
226             }
227              
228             #------------------------------------------------------------------------------
229             # 2001-07-27 RCC: The get_one() variant of get() allows Wheel::Xyz to
230             # retrieve one filtered block at a time. This is necessary for filter
231             # changing and proper input flow control.
232              
233             sub get_one_start {
234 20     20 1 28 my ($self, $stream) = @_;
235 20         67 $self->[BUFFER] .= join('', @$stream);
236 20 50       77 if( $self->[MAX_BUFFER] < length( $self->[BUFFER] ) ) {
237 0         0 $self->[BAD_BUFFER] = "Framing buffer exceeds the limit";
238 0 0       0 die $self->[BAD_BUFFER] unless $self->[NO_FATALS];
239             }
240             }
241              
242             sub get_one {
243 40     40 1 58 my $self = shift;
244              
245             # Need to check lengths in octets, not characters.
246 15 50   15   29 BEGIN { eval { require bytes } and bytes->import; }
  15         770  
247              
248 40 50       95 if( $self->[BAD_BUFFER] ) {
249 0         0 my $err = $self->[BAD_BUFFER];
250 0         0 $self->[BAD_BUFFER] = '';
251 0         0 return [ $err ];
252             }
253              
254 40 100 100     305 if (
255             $self->[BUFFER] =~ /^(\d+)\0/ and
256             length($self->[BUFFER]) >= $1 + length($1) + 1
257             ) {
258 23         64 substr($self->[BUFFER], 0, length($1) + 1) = "";
259 23         48 my $next_message = substr($self->[BUFFER], 0, $1);
260 23         36 substr($self->[BUFFER], 0, $1) = "";
261 23 50       44 $next_message = uncompress($next_message) if $self->[COMPRESS];
262              
263 23 50       49 unless ($self->[NO_FATALS]) {
264 23         72 return [ $self->[THAW]->($next_message) ];
265             }
266              
267 0         0 my $thawed = eval { $self->[THAW]->($next_message) };
  0         0  
268 0 0       0 return [ "$@" ] if $@;
269 0         0 return [ $thawed ];
270             }
271              
272 17         44 return [ ];
273             }
274              
275             #------------------------------------------------------------------------------
276             # freeze one or more references, and return a string representing them
277              
278             sub put {
279 101     101 1 176 my ($self, $references) = @_;
280              
281             # Need to check lengths in octets, not characters.
282 15 50   15   3275 BEGIN { eval { require bytes } and bytes->import; }
  15         139  
283              
284 101 50       379 my @raw = map {
285 101         323 confess "Choking on a non-reference ($_)" unless ref();
286 101         1506 my $frozen = $self->[FREEZE]->($_);
287 101 50       6930 $frozen = compress($frozen) if $self->[COMPRESS];
288 101         795 length($frozen) . "\0" . $frozen;
289             } @$references;
290 101         1988 \@raw;
291             }
292              
293             #------------------------------------------------------------------------------
294             # Return everything we have outstanding. Do not destroy our framing
295             # buffer, though.
296              
297             sub get_pending {
298 12     12 1 627 my $self = shift;
299 12 100       35 return undef unless length $self->[BUFFER];
300 4         11 return [ $self->[BUFFER] ];
301             }
302              
303             1;
304              
305             __END__