File Coverage

blib/lib/IO/Async/Protocol/Stream.pm
Criterion Covered Total %
statement 48 48 100.0
branch 16 22 72.7
condition 3 3 100.0
subroutine 13 13 100.0
pod 5 5 100.0
total 85 91 93.4


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2010-2013 -- leonerd@leonerd.org.uk
5              
6             package IO::Async::Protocol::Stream;
7              
8 3     3   1639 use strict;
  3         8  
  3         92  
9 3     3   15 use warnings;
  3         7  
  3         125  
10              
11             our $VERSION = '0.801';
12              
13 3     3   17 use base qw( IO::Async::Protocol );
  3         6  
  3         1103  
14              
15 3     3   22 use Carp;
  3         6  
  3         1862  
16              
17             =head1 NAME
18              
19             C - base class for stream-based protocols
20              
21             =head1 SYNOPSIS
22              
23             Most likely this class will be subclassed to implement a particular network
24             protocol.
25              
26             package Net::Async::HelloWorld;
27              
28             use strict;
29             use warnings;
30             use base qw( IO::Async::Protocol::Stream );
31              
32             sub on_read
33             {
34             my $self = shift;
35             my ( $buffref, $eof ) = @_;
36              
37             return 0 unless $$buffref =~ s/^(.*)\n//;
38             my $line = $1;
39              
40             if( $line =~ m/^HELLO (.*)/ ) {
41             my $name = $1;
42              
43             $self->invoke_event( on_hello => $name );
44             }
45              
46             return 1;
47             }
48              
49             sub send_hello
50             {
51             my $self = shift;
52             my ( $name ) = @_;
53              
54             $self->write( "HELLO $name\n" );
55             }
56              
57             This small example elides such details as error handling, which a real
58             protocol implementation would be likely to contain.
59              
60             =head1 DESCRIPTION
61              
62             This subclass of L is intended to stand as a base class
63             for implementing stream-based protocols. It provides an interface similar to
64             L, primarily, a C method and an C event
65             handler.
66              
67             It contains an instance of an L object which it uses for
68             actual communication, rather than being a subclass of it, allowing a level of
69             independence from the actual stream being used. For example, the stream may
70             actually be an L to allow the protocol to be used over
71             SSL.
72              
73             As with L, it is required that by the time the protocol
74             object is added to a Loop, that it either has an C method, or has
75             been configured with an C callback handler.
76              
77             =cut
78              
79             =head1 EVENTS
80              
81             The following events are invoked, either using subclass methods or CODE
82             references in parameters:
83              
84             =head2 $ret = on_read \$buffer, $eof
85              
86             =head2 on_read_eof
87              
88             =head2 on_write_eof
89              
90             The event handlers are invoked identically to L.
91              
92             =head2 on_closed
93              
94             The C handler is optional, but if provided, will be invoked after
95             the stream is closed by either side (either because the C method has
96             been invoked on it, or on an incoming EOF).
97              
98             =cut
99              
100             =head1 PARAMETERS
101              
102             The following named parameters may be passed to C or C:
103              
104             =head2 on_read => CODE
105              
106             =head2 on_read_eof => CODE
107              
108             =head2 on_write_eof => CODE
109              
110             CODE references for the events.
111              
112             =head2 handle => IO
113              
114             A shortcut for the common case where the transport only needs to be a plain
115             L object. If this argument is provided without a
116             C object, a new L object will be built around
117             the given IO handle, and used as the transport.
118              
119             =cut
120              
121             sub configure
122             {
123 12     12 1 1217 my $self = shift;
124 12         29 my %params = @_;
125              
126 12         28 for (qw( on_read on_read_eof on_write_eof )) {
127 36 100       130 $self->{$_} = delete $params{$_} if exists $params{$_};
128             }
129              
130 12 100 100     59 if( !exists $params{transport} and my $handle = delete $params{handle} ) {
131 2         707 require IO::Async::Stream;
132 2         27 $params{transport} = IO::Async::Stream->new( handle => $handle );
133             }
134              
135 12         64 $self->SUPER::configure( %params );
136              
137 12 100       33 if( $self->loop ) {
138 5 50       15 $self->can_event( "on_read" ) or
139             croak 'Expected either an on_read callback or to be able to ->on_read';
140             }
141             }
142              
143             sub _add_to_loop
144             {
145 5     5   10 my $self = shift;
146              
147 5 50       22 $self->can_event( "on_read" ) or
148             croak 'Expected either an on_read callback or to be able to ->on_read';
149             }
150              
151             sub setup_transport
152             {
153 6     6 1 10 my $self = shift;
154 6         13 my ( $transport ) = @_;
155              
156 6         24 $self->SUPER::setup_transport( $transport );
157              
158             $transport->configure(
159             on_read => $self->_replace_weakself( sub {
160 9 50   9   28 my $self = shift or return;
161 9         60 $self->invoke_event( on_read => @_ );
162             } ),
163             on_read_eof => $self->_replace_weakself( sub {
164 2 50   2   7 my $self = shift or return;
165 2         12 $self->maybe_invoke_event( on_read_eof => @_ );
166             } ),
167             on_write_eof => $self->_replace_weakself( sub {
168 1 50   1   6 my $self = shift or return;
169 1         3 $self->maybe_invoke_event( on_write_eof => @_ );
170 6         45 } ),
171             );
172             }
173              
174             sub teardown_transport
175             {
176 1     1 1 2 my $self = shift;
177 1         2 my ( $transport ) = @_;
178              
179 1         5 $transport->configure(
180             on_read => undef,
181             );
182              
183 1         7 $self->SUPER::teardown_transport( $transport );
184             }
185              
186             =head1 METHODS
187              
188             =cut
189              
190             =head2 write
191              
192             $protocol->write( $data )
193              
194             Writes the given data by calling the C method on the contained
195             transport stream.
196              
197             =cut
198              
199             sub write
200             {
201 3     3 1 1824 my $self = shift;
202 3         10 my ( $data, %args ) = @_;
203              
204 3 100       13 if( ref $data eq "CODE" ) {
205 1         5 $data = $self->_replace_weakself( $data );
206             }
207              
208 3 100       11 if( $args{on_flush} ) {
209 1         4 $args{on_flush} = $self->_replace_weakself( $args{on_flush} );
210             }
211              
212 3 50       11 my $transport = $self->transport or croak "Attempted to ->write to a ".ref($self)." with no transport";
213 3         19 $transport->write( $data, %args );
214             }
215              
216             =head2 connect
217              
218             $protocol->connect( %args )
219              
220             Sets up a connection to a peer, and configures the underlying C for
221             the Protocol. Calls L C with C set to
222             C<"stream">.
223              
224             =cut
225              
226             sub connect
227             {
228 1     1 1 123 my $self = shift;
229 1         8 $self->SUPER::connect(
230             @_,
231             socktype => "stream",
232             );
233             }
234              
235             =head1 AUTHOR
236              
237             Paul Evans
238              
239             =cut
240              
241             0x55AA;