File Coverage

blib/lib/POE/Filter/Line.pm
Criterion Covered Total %
statement 91 93 97.8
branch 47 52 90.3
condition 17 21 80.9
subroutine 10 10 100.0
pod 5 5 100.0
total 170 181 93.9


line stmt bran cond sub pod time code
1             package POE::Filter::Line;
2              
3 104     104   2203 use strict;
  104         140  
  104         3190  
4 104     104   35934 use POE::Filter;
  104         176  
  104         2762  
5              
6 104     104   503 use vars qw($VERSION @ISA);
  104         130  
  104         5816  
7             $VERSION = '1.366'; # NOTE - Should be #.### (three decimal places)
8             @ISA = qw(POE::Filter);
9              
10 104     104   439 use Carp qw(carp croak);
  104         121  
  104         16204  
11              
12             sub DEBUG () { 0 }
13              
14             sub FRAMING_BUFFER () { 0 }
15             sub INPUT_REGEXP () { 1 }
16             sub OUTPUT_LITERAL () { 2 }
17             sub AUTODETECT_STATE () { 3 }
18             sub MAX_LENGTH () { 4 }
19             sub MAX_BUFFER () { 5 }
20             sub FIRST_UNUSED () { 6 } # First unused $self offset.
21              
22             sub AUTO_STATE_DONE () { 0x00 }
23             sub AUTO_STATE_FIRST () { 0x01 }
24             sub AUTO_STATE_SECOND () { 0x02 }
25              
26 104     104   674 use base 'Exporter';
  104         140  
  104         100753  
27             our @EXPORT_OK = qw( FIRST_UNUSED );
28              
29             #------------------------------------------------------------------------------
30              
31             sub new {
32 1037     1037 1 29601 my $type = shift;
33              
34 1037 100 100     6384 croak "$type requires an even number of parameters" if @_ and @_ & 1;
35 1036         2478 my %params = @_;
36              
37 1036 100 66     3129 croak "$type cannot have both Regexp and Literal line endings" if (
38             defined $params{Regexp} and defined $params{Literal}
39             );
40              
41 1035         1154 my ($input_regexp, $output_literal);
42 1035         1113 my $autodetect = AUTO_STATE_DONE;
43              
44             # Literal newline for both incoming and outgoing. Every other known
45             # parameter conflicts with this one.
46 1035 100       1776 if (defined $params{Literal}) {
47 679 100 66     3287 croak "A defined Literal must have a nonzero length"
48             unless defined($params{Literal}) and length($params{Literal});
49 678         1119 $input_regexp = quotemeta $params{Literal};
50 678         732 $output_literal = $params{Literal};
51 678 100 100     5632 if (
      100        
52             exists $params{InputLiteral} or # undef means something
53             defined $params{InputRegexp} or
54             defined $params{OutputLiteral}
55             ) {
56 3         346 croak "$type cannot have Literal with any other parameter";
57             }
58             }
59              
60             # Input and output are specified separately, then.
61             else {
62              
63             # Input can be either a literal or a regexp. The regexp may be
64             # compiled or not; we don't rightly care at this point.
65 356 100       1088 if (exists $params{InputLiteral}) {
    100          
66 5         7 $input_regexp = $params{InputLiteral};
67              
68             # InputLiteral is defined. Turn it into a regexp and be done.
69             # Otherwise we will autodetect it.
70 5 100 66     13 if (defined($input_regexp) and length($input_regexp)) {
71 2         3 $input_regexp = quotemeta $input_regexp;
72             }
73             else {
74 3         2 $autodetect = AUTO_STATE_FIRST;
75 3         4 $input_regexp = '';
76             }
77              
78 5 100       122 croak "$type cannot have both InputLiteral and InputRegexp"
79             if defined $params{InputRegexp};
80             }
81             elsif (defined $params{InputRegexp}) {
82 2         4 $input_regexp = $params{InputRegexp};
83 2 50       7 croak "$type cannot have both InputLiteral and InputRegexp"
84             if defined $params{InputLiteral};
85             }
86             else {
87 349         443 $input_regexp = "(\\x0D\\x0A?|\\x0A\\x0D?)";
88             }
89              
90 355 100       646 if (defined $params{OutputLiteral}) {
91 6         9 $output_literal = $params{OutputLiteral};
92             }
93             else {
94 349         375 $output_literal = "\x0D\x0A";
95             }
96             }
97              
98 1030         4770 my $max_buffer = $type->__param_max( MaxBuffer => 512*1024*1024, \%params );
99 1028         2553 my $max_length = $type->__param_max( MaxLength => 64*1024*1024, \%params );
100 1026 100       2169 croak "MaxBuffer is not large enough for MaxLength blocks"
101             unless $max_buffer >= $max_length;
102              
103 1025         2151 delete @params{qw(Literal InputLiteral OutputLiteral InputRegexp MaxLength MaxBuffer)};
104 1025 50       2124 carp("$type ignores unknown parameters: ", join(', ', sort keys %params))
105             if scalar keys %params;
106              
107 1025         3395 my $self = bless [
108             '', # FRAMING_BUFFER
109             $input_regexp, # INPUT_REGEXP
110             $output_literal, # OUTPUT_LITERAL
111             $autodetect, # AUTODETECT_STATE
112             $max_length, # MAX_LENGTH
113             $max_buffer # MAX_BUFFER
114             ], $type;
115              
116 1025         903 DEBUG and warn join ':', @$self;
117              
118 1025         3662 $self;
119             }
120              
121              
122             #------------------------------------------------------------------------------
123             # get() is inherited from POE::Filter.
124              
125             #------------------------------------------------------------------------------
126             # 2001-07-27 RCC: Add get_one_start() and get_one() to correct filter
127             # changing and make input flow control possible.
128              
129             sub get_one_start {
130 567     567 1 1663 my ($self, $stream) = @_;
131              
132 567         674 DEBUG and do {
133             my $temp = join '', @$stream;
134             $temp = unpack 'H*', $temp;
135             warn "got some raw data: $temp\n";
136             };
137              
138 567         3355 $self->[FRAMING_BUFFER] .= join '', @$stream;
139 567 100       2574 die "Framing buffer exceeds the limit"
140             if $self->[MAX_BUFFER] < length( $self->[FRAMING_BUFFER] );
141             }
142              
143             # TODO There is a lot of code duplicated here. What can be done?
144              
145             sub get_one {
146 2991     2991 1 4308 my $self = shift;
147              
148             # Process as many newlines an we can find.
149 2991         2698 LINE: while (1) {
150              
151             # Autodetect is done, or it never started. Parse some buffer!
152 2993 100       5699 unless ($self->[AUTODETECT_STATE]) {
153 2986         2010 DEBUG and warn unpack 'H*', $self->[INPUT_REGEXP];
154             last LINE
155 2986 100       61325 unless $self->[FRAMING_BUFFER] =~ s/^(.*?)$self->[INPUT_REGEXP]//s;
156 2436         2477 DEBUG and warn "got line: <<", unpack('H*', $1), ">>\n";
157 2436         4703 my $line = $1;
158 2436 100       4925 die "Next line exceeds maximum line length"
159             if length( $line ) > $self->[MAX_LENGTH];
160              
161 2435         7631 return [ $line ];
162             }
163              
164             # Waiting for the first line ending. Look for a generic newline.
165 7 100       12 if ($self->[AUTODETECT_STATE] & AUTO_STATE_FIRST) {
166             last LINE
167 3 50       16 unless $self->[FRAMING_BUFFER] =~ s/^(.*?)(\x0D\x0A?|\x0A\x0D?)//;
168              
169 3         7 my $line = $1;
170              
171             # The newline can be complete under two conditions. First: If
172             # it's two characters. Second: If there's more data in the
173             # framing buffer. Loop around in case there are more lines.
174 3 100 66     11 if ( (length($2) == 2) or
175             (length $self->[FRAMING_BUFFER])
176             ) {
177 1         2 DEBUG and warn "detected complete newline after line: <<$1>>\n";
178 1         1 $self->[INPUT_REGEXP] = $2;
179 1         1 $self->[AUTODETECT_STATE] = AUTO_STATE_DONE;
180             }
181              
182             # The regexp has matched a potential partial newline. Save it,
183             # and move to the next state. There is no more data in the
184             # framing buffer, so we're done.
185             else {
186 2         2 DEBUG and warn "detected suspicious newline after line: <<$1>>\n";
187 2         3 $self->[INPUT_REGEXP] = $2;
188 2         2 $self->[AUTODETECT_STATE] = AUTO_STATE_SECOND;
189             }
190 3 50       7 die "Next line exceeds maximum line length"
191             if length( $line ) > $self->[MAX_LENGTH];
192              
193 3         7 return [ $line ];
194             }
195              
196             # Waiting for the second line beginning. Bail out if we don't
197             # have anything in the framing buffer.
198 4 50       8 if ($self->[AUTODETECT_STATE] & AUTO_STATE_SECOND) {
199 4 100       8 return [ ] unless length $self->[FRAMING_BUFFER];
200              
201             # Test the first character to see if it completes the previous
202             # potentially partial newline.
203 2 100       6 if (
    100          
204             substr($self->[FRAMING_BUFFER], 0, 1) eq
205             ( $self->[INPUT_REGEXP] eq "\x0D" ? "\x0A" : "\x0D" )
206             ) {
207              
208             # Combine the first character with the previous newline, and
209             # discard the newline from the buffer. This is two statements
210             # for backward compatibility.
211 1         1 DEBUG and warn "completed newline after line: <<$1>>\n";
212 1         2 $self->[INPUT_REGEXP] .= substr($self->[FRAMING_BUFFER], 0, 1);
213 1         2 substr($self->[FRAMING_BUFFER], 0, 1) = '';
214             }
215 0         0 elsif (DEBUG) {
216             warn "decided prior suspicious newline is okay\n";
217             }
218              
219             # Regardless, whatever is in INPUT_REGEXP is now a complete
220             # newline. End autodetection, post-process the found newline,
221             # and loop to see if there are other lines in the buffer.
222 2         2 $self->[INPUT_REGEXP] = $self->[INPUT_REGEXP];
223 2         1 $self->[AUTODETECT_STATE] = AUTO_STATE_DONE;
224 2         6 next LINE;
225             }
226              
227 0         0 die "consistency error: AUTODETECT_STATE = $self->[AUTODETECT_STATE]";
228             }
229              
230 550         1425 return [ ];
231             }
232              
233             #------------------------------------------------------------------------------
234             # New behavior. First translate system newlines ("\n") into whichever
235             # newlines are supposed to be sent. Second, add a trailing newline if
236             # one doesn't already exist. Since the referenced output list is
237             # supposed to contain one line per element, we also do a split and
238             # join. Bleah. ... why isn't the code doing what the comment says?
239              
240             sub put {
241 316     316 1 3808 my ($self, $lines) = @_;
242              
243 316         377 my @raw;
244 316         655 foreach (@$lines) {
245 340         1409 push @raw, $_ . $self->[OUTPUT_LITERAL];
246             }
247              
248 316         2509 \@raw;
249             }
250              
251             #------------------------------------------------------------------------------
252              
253             sub get_pending {
254 18     18 1 545 my $self = shift;
255 18 100       51 return [ $self->[FRAMING_BUFFER] ] if length $self->[FRAMING_BUFFER];
256 12         26 return undef;
257             }
258              
259             1;
260              
261             __END__