File Coverage

blib/lib/Metabrik/Server/Tcp.pm
Criterion Covered Total %
statement 9 127 7.0
branch 0 38 0.0
condition 0 11 0.0
subroutine 3 14 21.4
pod 1 11 9.0
total 13 201 6.4


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # server::tcp Brik
5             #
6             package Metabrik::Server::Tcp;
7 1     1   616 use strict;
  1         2  
  1         29  
8 1     1   5 use warnings;
  1         1  
  1         27  
9              
10 1     1   5 use base qw(Metabrik);
  1         2  
  1         1737  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable socket netcat) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             hostname => [ qw(listen_hostname) ],
20             port => [ qw(listen_port) ],
21             listen => [ qw(listen) ],
22             use_ipv4 => [ qw(0|1) ],
23             use_ipv6 => [ qw(0|1) ],
24             socket => [ qw(server_socket) ],
25             select => [ qw(select) ],
26             clients => [ qw(connected_clients) ],
27             },
28             attributes_default => {
29             hostname => 'localhost',
30             port => 8888,
31             listen => 10,
32             use_ipv4 => 1,
33             use_ipv6 => 0,
34             clients => {},
35             },
36             commands => {
37             start => [ qw(listen_hostname|OPTIONAL listen_port|OPTIONAL) ],
38             stop => [ ],
39             is_started => [ ],
40             wait_readable => [ ],
41             get_clients_count => [ ],
42             get_last_client => [ ],
43             get_last_client_id => [ ],
44             accept => [ ],
45             },
46             require_modules => {
47             'IO::Socket' => [ ],
48             'IO::Select' => [ ],
49             'IO::Socket::INET' => [ ],
50             },
51             };
52             }
53              
54             sub start {
55 0     0 0   my $self = shift;
56 0           my ($hostname, $port, $root) = @_;
57              
58 0   0       $hostname ||= $self->hostname;
59 0   0       $port ||= $self->port;
60 0 0         if ($port !~ /^\d+$/) {
61 0           return $self->log->error("start: port [$port] must be an integer");
62             }
63              
64 0           my $use_ipv4 = $self->use_ipv4;
65 0           my $use_ipv6 = $self->use_ipv6;
66 0           my $domain = IO::Socket::AF_INET(); # XXX: TODO
67 0           my $listen = $self->listen;
68              
69 0           my $socket = IO::Socket::INET->new(
70             LocalHost => $hostname,
71             LocalPort => $port,,
72             Proto => 'tcp',
73             ReuseAddr => 1,
74             Listen => $listen,
75             Domain => $domain,
76             );
77 0 0         if (! defined($socket)) {
78 0           return $self->log->error("start: unable to create server: $!");
79             }
80              
81 0           $socket->blocking(0);
82 0           $socket->autoflush(1);
83              
84 0           my $select = IO::Select->new;
85 0           $select->add($socket);
86              
87 0           $self->select($select);
88              
89 0           $self->log->info("start: starting server on [$hostname]:$port");
90              
91 0           return $self->socket($socket);
92             }
93              
94             sub stop {
95 0     0 0   my $self = shift;
96              
97 0 0         if (! $self->is_started) {
98 0           return $self->log->error($self->brik_help_run('start'));
99             }
100              
101 0           my $socket = $self->socket;
102 0           my $select = $self->select;
103 0           my $clients = $self->clients;
104              
105 0           for my $this (keys %$clients) {
106 0           $select->remove($clients->{$this}{socket});
107 0           close($clients->{$this}{socket});
108 0           delete $clients->{$this};
109             }
110              
111 0           $select->remove($socket);
112 0           close($socket);
113              
114 0           $self->socket(undef);
115 0           $self->select(undef);
116 0           $self->clients({});
117              
118 0           return 1;
119             }
120              
121             sub is_started {
122 0     0 0   my $self = shift;
123              
124 0           my $socket = $self->socket;
125 0 0         if (! defined($socket)) {
126 0           return 0;
127             }
128              
129 0           return 1;
130             }
131              
132             sub wait_readable {
133 0     0 0   my $self = shift;
134 0           my ($timeout) = @_;
135              
136 0 0         if (! $self->is_started) {
137 0           return $self->log->error($self->brik_help_run('start'));
138             }
139              
140 0   0       $timeout ||= 0; # No timeout
141              
142 0           my $socket = $self->socket;
143 0           my $select = $self->select;
144              
145 0           my @readable = $select->can_read;
146 0 0         if (@readable > 0) {
147 0           return \@readable;
148             }
149              
150 0           return 0; # Timeout occured
151             }
152              
153             sub get_clients_count {
154 0     0 0   my $self = shift;
155              
156 0 0         if (! $self->is_started) {
157 0           return $self->log->error($self->brik_help_run('start'));
158             }
159              
160 0           my $clients = $self->{clients};
161              
162 0           return keys %$clients;
163             }
164              
165             sub get_last_client {
166 0     0 0   my $self = shift;
167              
168 0 0         if (! $self->is_started) {
169 0           return $self->log->error($self->brik_help_run('start'));
170             }
171              
172 0           my $clients = $self->{clients};
173              
174 0           my $last = 0;
175 0           for my $this (keys %$clients) {
176 0 0         if ($this > $last) {
177 0           $last = $this;
178             }
179             }
180              
181 0           return $clients->{$last};
182             }
183              
184             sub get_last_client_id {
185 0     0 0   my $self = shift;
186              
187 0 0         if (! $self->is_started) {
188 0           return $self->log->error($self->brik_help_run('start'));
189             }
190              
191 0           my $clients = $self->{clients};
192              
193 0           my $last = 0;
194 0           for my $this (keys %$clients) {
195 0 0         if ($this > $last) {
196 0           $last = $this;
197             }
198             }
199              
200 0           return $last;
201             }
202              
203             sub accept {
204 0     0 0   my $self = shift;
205              
206 0 0         if (! $self->is_started) {
207 0           return $self->log->error($self->brik_help_run('start'));
208             }
209              
210 0           my $socket = $self->socket;
211 0           my $select = $self->select;
212 0           my $clients = $self->clients;
213              
214 0           my $client = $socket->accept;
215 0           $client->blocking(0);
216 0           $client->autoflush(1);
217              
218 0           $select->add($client);
219              
220 0           my $last = $self->get_last_client_id;
221              
222 0           my $new = {
223             id => $last + 1,
224             socket => $client,
225             ipv4 => $client->peerhost,
226             port => $client->peerport,
227             };
228              
229 0           return $clients->{$last+1} = $new;
230             }
231              
232             sub read {
233 0     0 0   my $self = shift;
234 0           my ($socket) = @_;
235              
236 0 0         if (! $self->is_started) {
237 0           return $self->log->error($self->brik_help_run('start'));
238             }
239              
240 0           my $buf = '';
241 0           my $chunk = 512;
242 0           my @ready = ();
243 0           while (1) {
244 0           my $n = $socket->sysread(my $tmp = '', $chunk);
245 0 0         if (! defined($n)) {
246 0           last; # Should test for EWOULDBLOCK. If so, we can return. Otherwise, handle error.
247             }
248 0 0 0       if ($n == 0 && length($buf)) { # EOF, but we send what we read
249 0           return $buf;
250             }
251 0 0         if ($n == 0) { # EOF, nothing read
252 0           return;
253             }
254 0           $buf .= $tmp;
255             }
256              
257 0           return $buf;
258             }
259              
260             sub client_disconnected {
261 0     0 0   my $self = shift;
262 0           my ($id) = @_;
263              
264 0 0         if (! $self->is_started) {
265 0           return $self->log->error($self->brik_help_run('start'));
266             }
267              
268 0 0         $self->brik_help_run_undef_arg('client_disconnected', $id) or return;
269              
270 0           my $clients = $self->clients;
271 0           my $select = $self->select;
272              
273 0 0         if (exists($clients->{$id})) {
274 0           close($clients->{$id}{socket});
275 0           $select->remove($clients->{$id}{socket});
276 0           delete $clients->{$id};
277             }
278              
279 0           return 1;
280             }
281              
282             1;
283              
284             __END__