File Coverage

blib/lib/Net/Async/Tangence/Server.pm
Criterion Covered Total %
statement 36 36 100.0
branch 1 2 50.0
condition n/a
subroutine 10 10 100.0
pod 1 2 50.0
total 48 50 96.0


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-2011 -- leonerd@leonerd.org.uk
5              
6             package Net::Async::Tangence::Server;
7              
8 4     4   397799 use strict;
  4         6  
  4         92  
9 4     4   12 use warnings;
  4         4  
  4         87  
10              
11 4     4   1742 use IO::Async::Listener '0.36';
  4         4887  
  4         100  
12 4     4   21 use base qw( IO::Async::Listener );
  4         7  
  4         307  
13              
14             our $VERSION = '0.14';
15              
16 4     4   17 use Carp;
  4         4  
  4         191  
17              
18 4     4   1267 use Net::Async::Tangence::ServerProtocol;
  4         18  
  4         952  
19              
20             =head1 NAME
21              
22             C - serve C clients using C
23              
24             =head1 DESCRIPTION
25              
26             This subclass of L accepts L client
27             connections.
28              
29             =cut
30              
31             =head1 PARAMETERS
32              
33             The following named parameters may be passed to C or C:
34              
35             =over 8
36              
37             =item registry => Tangence::Registry
38              
39             The L for the server's objects.
40              
41             =back
42              
43             =cut
44              
45             sub _init
46             {
47 3     3   33439 my $self = shift;
48 3         10 my ( $params ) = @_;
49              
50             $params->{handle_constructor} = sub {
51 4     4   10 my $self = shift;
52              
53             return Net::Async::Tangence::ServerProtocol->new(
54             registry => $self->{registry},
55             on_closed => $self->_capture_weakself( sub {
56 2         14 my $self = shift;
57 2         17 $self->remove_child( $_[0] );
58 4         44 } ),
59             );
60 3         15 };
61              
62 3         21 $self->SUPER::_init( $params );
63              
64 3 50       55 $self->{registry} = delete $params->{registry} if exists $params->{registry};
65             }
66              
67             sub on_accept
68             {
69 4     4 1 5 my $self = shift;
70 4         5 my ( $conn ) = @_;
71              
72 4         27 $self->add_child( $conn );
73             }
74              
75             # Useful for testing
76             sub make_new_connection
77             {
78 4     4 0 1787 my $self = shift;
79 4         6 my ( $sock ) = @_;
80              
81             # Mass cheating
82 4         27 my $conn = $self->{handle_constructor}->( $self );
83              
84 4         286 $conn->configure( handle => $sock );
85 4         473 $self->on_accept( $conn );
86              
87 4         726 return $conn;
88             }
89              
90             =head1 AUTHOR
91              
92             Paul Evans
93              
94             =cut
95              
96             0x55AA;