Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

gutted and rewrote Filter::Line's innards for extra options

  • Loading branch information...
commit 197063a09af5a30ab0995938e74d60351e380022 1 parent 8096e26
@rcaputo authored
View
20 Changes
@@ -39,18 +39,32 @@ Version numbers have four fields: X.YYZZAA
| code. Migrate SocketFactory's code to ListenAccept, and write
| a test based on IO::Socket::INET sockets.
|
-| Add new newlines to Filter::Line.
-|
| Split the samples out into a separate distribution.
|
| Revise the POE web pages.
|
| Move the POE mailing list, which seems to have fallen on hard times.
|
+| Benchmark index vs. rindex vs. regexp for finding line terminators.
+|
`-----------------
-0.1101 2000.??.??
+0.1102 2000.07.27
+-----------------
+
+Dennis Taylor supplied a Filter::Line patch that allows new newline
+regexps. Bits of his patch relied on perl 5.005 or newer, so I wrote
+around them. I also added the ability to specify incoming newlines as
+literal strings, and it's now also possible to change the outbound
+line terminator.
+
+Added t/18_filter_line.t to test the now multi-faceted Filter::Line.
+
+Tweaked the way t/06_tk.t skips so it doesn't look like my problem.
+
+
+0.1101 2000.07.26
-----------------
This public release also contains the changes found in private testing
View
1  MANIFEST
@@ -81,3 +81,4 @@ t/14_wheels_ft.t
t/15_filter_block.t
t/16_filter_stream.t
t/17_filter_ref.t
+t/18_filter_line.t
View
15 lib/POE.pm
@@ -7,7 +7,7 @@ use strict;
use Carp;
use vars qw($VERSION);
-$VERSION = '0.1101';
+$VERSION = '0.1102';
sub import {
my $self = shift;
@@ -1017,9 +1017,20 @@ problem relating to anonymous subs, scope and @{} processing.
=item *
+Dennis Taylor
+
+Dennis Taylor is <dennis@funkplanet.com>. Dennis has been testing,
+debugging and patching bits here and there, such as Filter::Line which
+he improved by leaps in 0.1102. He's also the author of
+POE::Component::IRC, which isn't included here but may be found at
+either <http://www.infobot.org/dev/POE/> or
+<http://www.funkplanet.com/POE/>.
+
+=item *
+
Others?
-Anyone who has been forgotten, please contact me.
+Anyone who has been forgotten, please contact the author.
=back
View
150 lib/POE/Filter/Line.pm
@@ -3,13 +3,79 @@
package POE::Filter::Line;
use strict;
+use Carp;
+
+sub DEBUG () { 0 }
+
+sub FRAMING_BUFFER () { 0 }
+sub INPUT_REGEXP () { 1 }
+sub OUTPUT_LITERAL () { 2 }
#------------------------------------------------------------------------------
sub new {
my $type = shift;
- my $t='';
- my $self = bless \$t, $type; # we now use a scalar ref -PG
+
+ croak "$type requires an even number of parameters" if @_ and @_ & 1;
+ my %params = @_;
+
+ croak "$type cannot have both Regexp and Literal line endings"
+ if exists $params{Regexp} and exists $params{Literal};
+
+ my ($input_regexp, $output_literal);
+
+ # Literal newline for both incoming and outgoing. Every other known
+ # parameter conflicts with this one.
+ if (exists $params{Literal}) {
+ $input_regexp = quotemeta $params{Literal};
+ $output_literal = $params{Literal};
+ croak "$type cannot have Literal with any other parameter"
+ if ( exists $params{InputLiteral } or
+ exists $params{InputRegexp } or
+ exists $params{OutputLiteral}
+ );
+ }
+
+ # Input and output are specified separately, then.
+ else {
+
+ # Input can be either a literal or a regexp. The regexp may be
+ # compiled or not; we don't rightly care at this point.
+ if (exists $params{InputLiteral}) {
+ $input_regexp = quotemeta $params{InputLiteral};
+ croak "$type cannot have both InputLiteral and InputRegexp"
+ if exists $params{InputRegexp};
+ }
+ elsif (exists $params{InputRegexp}) {
+ $input_regexp = $params{InputRegexp};
+ croak "$type cannot have both InputLiteral and InputRegexp"
+ if exists $params{InputLiteral};
+ }
+ else {
+ $input_regexp = "(\\x0D\\x0A?|\\x0A\\x0D?)";
+ }
+
+ if (exists $params{OutputLiteral}) {
+ $output_literal = $params{OutputLiteral};
+ }
+ else {
+ $output_literal = "\x0D\x0A";
+ }
+ }
+
+ delete @params{qw(Literal InputLiteral OutputLiteral InputRegexp)};
+ if (keys %params) {
+ carp "$type ignores unknown parameters: ", join(', ', sort keys %params);
+ }
+
+ my $self =
+ bless [ '', # FRAMING_BUFFER
+ $input_regexp, # INPUT_REGEXP
+ $output_literal, # OUTPUT_LITERAL
+ ], $type;
+
+ DEBUG and warn join ':', @$self;
+
$self;
}
@@ -17,45 +83,47 @@ sub new {
sub get {
my ($self, $stream) = @_;
- $$self .= join('', @$stream);
- my @result;
- while ($$self =~ s/^([^\x0D\x0A]*)(\x0D\x0A?|\x0A\x0D?)//) {
- push(@result, $1);
+
+ $self->[FRAMING_BUFFER] .= join '', @$stream;
+
+ my @lines;
+ while ($self->[FRAMING_BUFFER] =~ s/^(.*?)$self->[INPUT_REGEXP]//) {
+ push @lines, $1;
}
- \@result;
+
+ \@lines;
}
#------------------------------------------------------------------------------
+# New behavior. First translate system newlines ("\n") into whichever
+# newlines are supposed to be sent. Second, add a trailing newline if
+# one doesn't already exist. Since the referenced output list is
+# supposed to contain one line per element, we also do a split and
+# join. Bleah.
sub put {
my ($self, $lines) = @_;
- my @raw = map { $_ . "\x0D\x0A" } @$lines;
+
+ my @raw;
+ foreach (@$lines) {
+ push @raw, $_ . $self->[OUTPUT_LITERAL];
+ }
+
\@raw;
}
#------------------------------------------------------------------------------
-sub get_pending
-{
- my($self)=@_;
- return unless $$self;
- my $ret=[$$self];
- $$self='';
- return $ret;
+sub get_pending {
+ my $self = shift;
+ my $framing_buffer = $self->[FRAMING_BUFFER];
+ $self->[FRAMING_BUFFER] = '';
+ return $framing_buffer;
}
###############################################################################
1;
-# <Abigail> All I did was change the put function to:
-# <Abigail> # Turn newlines into "\x0D\x0A". Do *not* add a trailing newline.
-# <Abigail> sub put {
-# <Abigail> my ($self, $lines) = @_;
-# <Abigail> # Make a copy.
-# <Abigail> my @raw = map {my $s = $_; $s =~ s/\n/\x0D\x0A/g; $s} @$lines;
-# <Abigail> \@raw;
-# <Abigail> }
-
__END__
=head1 NAME
@@ -64,7 +132,7 @@ POE::Filter::Line - POE Line Protocol Abstraction
=head1 SYNOPSIS
- $filter = new POE::Filter::Line();
+ $filter = POE::Filter::Line->new();
$arrayref_of_lines =
$filter->get($arrayref_of_raw_chunks_from_driver);
$arrayref_of_streamable_chunks_for_driver =
@@ -74,18 +142,37 @@ POE::Filter::Line - POE Line Protocol Abstraction
$arrayref_of_leftovers =
$filter->get_pending();
+ # To use a literal newline terminator for input and output:
+ $filter = POE::Filter::Line->new( Literal => "\x0D\x0A" );
+
+ # To terminate input lines with a string regexp:
+ $filter = POE::Filter::Line->new( InputRegexp => '[!:]',
+ OutputLiteral => "!"
+ );
+
+ # To terminate input lines with a compiled regexp (requires perl
+ # 5.005 or newer):
+ $filter = POE::Filter::Line->new( InputRegexp => qr/[!:]/,
+ OutputLiteral => "!"
+ );
+
=head1 DESCRIPTION
The Line filter translates streams to and from newline-separated
lines. The lines it returns do not contain newlines. Neither should
the lines given to it.
-Incoming newlines are recognized with the regexp
-C</(\x0D\x0A?|\x0A\x0D?)/>. Incomplete lines are buffered until a
-subsequent packet completes them.
+By default, incoming newline are recognized with a regular
+subexpression: C</(\x0D\x0A?|\x0A\x0D?)/>. This encompasses all sorts
+of variations on CR and LF, but it has a problem. If incoming data is
+broken between CR and LF, then the second character will be
+interpreted as a blank line. This doesn't happen often, but it can
+happen often enough. B<People are advised to specify custom newlines
+in applications where blank lines are significant.>
-Outgoing lines have the network newline attached to them:
-C<"\x0D\x0A">.
+By default, outgoing lines have traditional network newlines attached
+to them: C<"\x0D\x0A">, or CRLF. The C<OutputLiteral> parameter is
+used to specify a new one.
=head1 PUBLIC FILTER METHODS
@@ -98,7 +185,8 @@ POE::Filter::Stream
=head1 BUGS
-This filter's newlines are hard-coded.
+The default input newline regexp has a race condition where incomplete
+newlines can generate spurious blank input lines.
=head1 AUTHORS & COPYRIGHTS
View
2  tests/06_tk.t
@@ -23,7 +23,7 @@ BEGIN {
&test_setup(0, 'no DISPLAY is set');
}
eval 'use Tk';
- &test_setup(0, "Tk could not be used: $@") if length $@;
+ &test_setup(0, "use Tk failed (Tk probably isn't installed)") if length $@;
unless (exists $INC{'Tk.pm'}) {
&test_setup(0, 'the Tk module is not installed');
}
View
153 tests/18_filter_line.t
@@ -0,0 +1,153 @@
+#!/usr/bin/perl -w
+# $Id$
+
+# Exercises Filter::Line without the rest of POE.
+
+use strict;
+use lib qw(./lib ../lib);
+use POE::Filter::Line;
+
+my ($filter, $received, $sent, $base);
+
+use TestSetup;
+&test_setup(32);
+
+# Self-congratulatory backpatting.
+print "ok 1\n";
+
+# Test the line filter in default mode.
+$base = 2;
+$filter = POE::Filter::Line->new();
+
+$received = $filter->get( [ "a\x0D", "b\x0A", "c\x0D\x0A", "d\x0A\x0D" ] );
+if (@$received == 4) {
+ print "ok ", $base+0, "\n";
+ $sent = $filter->put( $received );
+ if (@$sent == 4) {
+ print "ok ", $base+1, "\n";
+ print 'not ' unless $sent->[0] eq "a\x0D\x0A"; print "ok ", $base+2, "\n";
+ print 'not ' unless $sent->[1] eq "b\x0D\x0A"; print "ok ", $base+3, "\n";
+ print 'not ' unless $sent->[2] eq "c\x0D\x0A"; print "ok ", $base+4, "\n";
+ print 'not ' unless $sent->[3] eq "d\x0D\x0A"; print "ok ", $base+5, "\n";
+ }
+ else {
+ for (1..5) { print "not ok ", $base+$_, "\n"; }
+ }
+}
+else {
+ for (0..5) { print "not ok ", $base+$_, "\n"; }
+}
+
+# Test the line filter in literal mode.
+$base = 8;
+$filter = POE::Filter::Line->new( Literal => 'x' );
+
+$received = $filter->get( [ "axa", "bxb", "cxc", "dxd" ] );
+if (@$received == 4) {
+ print "ok ", $base+0, "\n";
+ $sent = $filter->put( $received );
+ if (@$sent == 4) {
+ print "ok ", $base+1, "\n";
+ print 'not ' unless $sent->[0] eq "ax"; print "ok ", $base+2, "\n";
+ print 'not ' unless $sent->[1] eq "abx"; print "ok ", $base+3, "\n";
+ print 'not ' unless $sent->[2] eq "bcx"; print "ok ", $base+4, "\n";
+ print 'not ' unless $sent->[3] eq "cdx"; print "ok ", $base+5, "\n";
+ }
+ else {
+ for (1..5) { print "not ok ", $base+$_, "\n"; }
+ }
+}
+else {
+ for (0..5) { print "not ok ", $base+$_, "\n"; }
+}
+
+# Test the line filter with different input and output literals.
+$base = 14;
+$filter = POE::Filter::Line->new( InputLiteral => 'x',
+ OutputLiteral => 'y',
+ );
+
+$received = $filter->get( [ "axa", "bxb", "cxc", "dxd" ] );
+if (@$received == 4) {
+ print "ok ", $base+0, "\n";
+ $sent = $filter->put( $received );
+ if (@$sent == 4) {
+ print "ok ", $base+1, "\n";
+ print 'not ' unless $sent->[0] eq "ay"; print "ok ", $base+2, "\n";
+ print 'not ' unless $sent->[1] eq "aby"; print "ok ", $base+3, "\n";
+ print 'not ' unless $sent->[2] eq "bcy"; print "ok ", $base+4, "\n";
+ print 'not ' unless $sent->[3] eq "cdy"; print "ok ", $base+5, "\n";
+ }
+ else {
+ for (1..5) { print "not ok ", $base+$_, "\n"; }
+ }
+}
+else {
+ for (0..5) { print "not ok ", $base+$_, "\n"; }
+}
+
+# Test the line filter with an input string regexp and an output
+# literal.
+$base = 20;
+$filter = POE::Filter::Line->new( InputRegexp => '[xy]',
+ OutputLiteral => '!',
+ );
+
+$received = $filter->get( [ "axa", "byb", "cxc", "dyd" ] );
+if (@$received == 4) {
+ print "ok ", $base+0, "\n";
+ $sent = $filter->put( $received );
+ if (@$sent == 4) {
+ print "ok ", $base+1, "\n";
+ print 'not ' unless $sent->[0] eq "a!"; print "ok ", $base+2, "\n";
+ print 'not ' unless $sent->[1] eq "ab!"; print "ok ", $base+3, "\n";
+ print 'not ' unless $sent->[2] eq "bc!"; print "ok ", $base+4, "\n";
+ print 'not ' unless $sent->[3] eq "cd!"; print "ok ", $base+5, "\n";
+ }
+ else {
+ for (1..5) { print "not ok ", $base+$_, "\n"; }
+ }
+}
+else {
+ for (0..5) { print "not ok ", $base+$_, "\n"; }
+}
+
+# Test the line filter with an input compiled regexp and an output
+# literal.
+
+$base = 26;
+my $compiled_regexp;
+BEGIN { eval { $compiled_regexp = qr/[xy]/; }; };
+
+if (defined $compiled_regexp) {
+ $filter = POE::Filter::Line->new( InputRegexp => $compiled_regexp,
+ OutputLiteral => '!',
+ );
+
+ $received = $filter->get( [ "axa", "byb", "cxc", "dyd" ] );
+ if (@$received == 4) {
+ print "ok ", $base+0, "\n";
+ $sent = $filter->put( $received );
+ if (@$sent == 4) {
+ print "ok ", $base+1, "\n";
+ print 'not ' unless $sent->[0] eq "a!"; print "ok ", $base+2, "\n";
+ print 'not ' unless $sent->[1] eq "ab!"; print "ok ", $base+3, "\n";
+ print 'not ' unless $sent->[2] eq "bc!"; print "ok ", $base+4, "\n";
+ print 'not ' unless $sent->[3] eq "cd!"; print "ok ", $base+5, "\n";
+ }
+ else {
+ for (1..5) { print "not ok ", $base+$_, "\n"; }
+ }
+ }
+ else {
+ for (0..5) { print "not ok ", $base+$_, "\n"; }
+ }
+}
+else {
+ for (0..5) {
+ print "skip ", $base+$_, " # compiled regexps not supported\n";
+ }
+}
+
+# And one to grow on!
+print "ok 32\n";
Please sign in to comment.
Something went wrong with that request. Please try again.