File Coverage

blib/lib/Mojo/Server/TCP.pm
Criterion Covered Total %
statement 40 54 74.0
branch 7 12 58.3
condition n/a
subroutine 8 11 72.7
pod 4 4 100.0
total 59 81 72.8


line stmt bran cond sub pod time code
1             package Mojo::Server::TCP;
2              
3             =head1 NAME
4              
5             Mojo::Server::TCP - Generic TCP server
6              
7             =head1 VERSION
8              
9             0.05
10              
11             =head1 SYNOPSIS
12              
13             use Mojo::Server::TCP;
14             my $echo = Mojo::Server::TCP->new(listen => ['tcp//*:9000']);
15              
16             $echo->on(read => sub {
17             my($echo, $id, $bytes, $stream) = @_;
18             $stream->write($bytes);
19             });
20              
21             $echo->start;
22              
23             =head1 DESCRIPTION
24              
25             L is a generic TCP server based on the logic of
26             the L.
27              
28             =cut
29              
30 2     2   244402 use Mojo::Base 'Mojo::EventEmitter';
  2         4  
  2         11  
31 2     2   2600 use Mojo::Loader;
  2         80597  
  2         22  
32 2     2   1349 use Mojo::URL;
  2         17159  
  2         25  
33 2 50   2   124 use constant DEBUG => $ENV{MOJO_SERVER_DEBUG} ? 1 : 0;
  2         4  
  2         2246  
34              
35             our $VERSION = '0.05';
36              
37             =head1 EVENTS
38              
39             =head2 connect
40              
41             $self->on(connect => sub { my($self, $id) = @_ });
42              
43             Emitted safely when a new client connects to the server.
44             C<$id> is a unique string used to identify the connection.
45              
46             =head2 close
47              
48             $self->on(close => sub { my($self, $id) = @_ });
49              
50             Emitted safely if the stream gets closed.
51             C<$id> is a unique string used to identify the connection.
52              
53             =head2 error
54              
55             $self->on(error => sub { my($self, $id, $str) = @_ });
56              
57             C<$id> is a unique string used to identify the connection and C<$err>
58             holds the error message.
59              
60             =head2 read
61              
62             $self->on(read => sub { my($self, $id, $bytes, $stream) = @_ });
63              
64             Emitted safely if new data arrives on the stream.
65             C<$id> is a unique string used to identify the connection. C<$bytes> holds the
66             incoming data and C<$stream> is a L object you can use
67             to respond back to the client.
68              
69             The C<$stream> object can also be retrived in your code using this code:
70              
71             $stream = $self->ioloop->stream($id);
72              
73             It is much safer to avoid memory leaks to pass C<$id> around instead of the
74             C<$stream> object.
75              
76             =head2 timeout
77              
78             $self->on(timeout => sub { my($self, $id) = @_ });
79              
80             Emitted safely if the stream has been inactive for too long and will get
81             closed automatically.
82             C<$id> is a unique string used to identify the connection.
83              
84             =head1 ATTRIBUTES
85              
86             =head2 ioloop
87              
88             $ioloop = $self->ioloop;
89             $self = $self->ioloop(Mojo::IOLoop->new);
90              
91             Returns the L object.
92              
93             =head2 listen
94              
95             $array_ref = $self->listen;
96             $self = $self->listen(['tcp://localhost:3000']);
97              
98             List of one or more locations to listen on, defaults to "tcp://*:3000".
99              
100             =head2 server_class
101              
102             $str = $daemon->server_class;
103             $self = $self->server_class('Mojo::Server::Prefork');
104              
105             Used to set a custom server class. The default is L.
106             Check out L if you want a faster server.
107              
108             =cut
109              
110 0     0 1 0 sub ioloop { shift->_server->ioloop(@_); }
111             has listen => sub { ['tcp://*:3000']; };
112             has server_class => 'Mojo::Server::Daemon';
113             has _server => sub {
114             my $self = shift;
115             my $e = Mojo::Loader->new->load($self->server_class);
116            
117             $e and die $e;
118             $self->server_class->new(listen => []);
119             };
120              
121             =head1 METHODS
122              
123             =head2 run
124              
125             $self = $self->run;
126              
127             Start accepting connections and run the server.
128              
129             =cut
130              
131             sub run {
132 1     1 1 2 my $self = shift;
133              
134 1     0   22 local $SIG{INT} = local $SIG{TERM} = sub { $self->_server->ioloop->stop };
  0         0  
135 1         2 $self->start->_server->setuidgid->ioloop->start;
136 1         1999944 $self;
137             }
138              
139             =head2 start
140              
141             $self = $self->start;
142              
143             Start listening for connections. See also L.
144              
145             =cut
146              
147             sub start {
148 3     3 1 4660 my $self = shift;
149              
150 3 100       16 if(!$self->{acceptors}) {
151 2         4 $self->_listen($_) for @{ $self->listen };
  2         67  
152             }
153 3 100       1747 if($self->{acceptors}) {
154 2         79 $self->_server->acceptors($self->{acceptors});
155             }
156              
157 3         103 $self->_server->start;
158 3         253 $self;
159             }
160              
161             =head2 stop
162              
163             $self = $self->stop;
164              
165             Stop the server.
166              
167             =cut
168              
169             sub stop {
170 1     1 1 2 my $self = shift;
171              
172 1         30 $self->_server->stop;
173 1         66 $self;
174             }
175              
176             sub _listen {
177 1     1   13 my $self = shift;
178 1         9 my $url = Mojo::URL->new(shift);
179 1         1051 my $query = $url->query;
180 1         31 my $verify = $query->param('verify');
181 1         89 my($options, $tls);
182              
183 1         75 $options = {
184             address => $url->host,
185             backlog => $self->_server->backlog,
186             port => $url->port,
187             reuse => scalar $query->param('reuse'),
188             };
189              
190 1         194 $options->{"tls_$_"} = scalar $query->param($_) for qw(ca cert ciphers key);
191 1 50       77 $options->{tls_verify} = hex $verify if defined $verify;
192 1 50       5 delete $options->{address} if $options->{address} eq '*';
193 1         8 $tls = $options->{tls} = $url->protocol eq 'tcps';
194            
195 1         50 Scalar::Util::weaken($self);
196 1         35 push @{$self->{acceptors}}, $self->_server->ioloop->server(
197             $options => sub {
198 0     0     my ($loop, $stream, $id) = @_;
199              
200 0           $self->emit(connect => $id);
201            
202 0           warn "-- Accept (@{[$stream->handle->peerhost]})\n" if DEBUG;
203 0           $stream->timeout($self->_server->inactivity_timeout);
204 0           $stream->on(close => sub { $self->emit(close => $id); });
  0            
205 0 0         $stream->on(error => sub { $self and $self->emit(error => $id, $_[1]); });
  0            
206 0           $stream->on(read => sub { $self->emit(read => $id, $_[1], $_[0]); });
  0            
207 0           $stream->on(timeout => sub { $self->emit(timeout => $id); });
  0            
208             }
209 1         1 );
210             }
211              
212             =head1 AUTHOR
213              
214             Jan Henning Thorsen - C
215              
216             =cut
217              
218             1;