File Coverage

blib/lib/PocketIO/Pool.pm
Criterion Covered Total %
statement 59 100 59.0
branch 5 26 19.2
condition 0 6 0.0
subroutine 15 19 78.9
pod 6 10 60.0
total 85 161 52.8


line stmt bran cond sub pod time code
1             package PocketIO::Pool;
2              
3 10     10   128528 use strict;
  10         25  
  10         435  
4 10     10   55 use warnings;
  10         18  
  10         359  
5              
6 10     10   57 use Scalar::Util qw(blessed);
  10         20  
  10         1180  
7              
8 10     10   7026 use PocketIO::Connection;
  10         36  
  10         442  
9              
10 10     10   359 use constant DEBUG => $ENV{POCKETIO_POOL_DEBUG};
  10         135  
  10         13790  
11              
12             sub new {
13 10     10 1 4732 my $class = shift;
14              
15 10         27 my $self = {@_};
16 10         29 bless $self, $class;
17              
18 10         49 $self->{connections} = {};
19 10         27 $self->{rooms} = {};
20 10         23 $self->{revrooms} = {};
21              
22 10         38 return $self;
23             }
24              
25             sub find_local_connection {
26 4     4 0 9 my $self = shift;
27 4         9 my ($conn) = @_;
28              
29 4 50       22 my $id = blessed $conn ? $conn->id : $conn;
30              
31 4         25 return $self->{connections}->{$id};
32             }
33              
34             sub find_connection {
35 4     4 1 12 my $self = shift;
36              
37 4         13 return $self->find_local_connection(@_);
38             }
39              
40             sub add_connection {
41 3     3 1 12 my $self = shift;
42 3         7 my $cb = pop @_;
43              
44 3         9 my $conn = $self->_build_connection(@_);
45              
46 3         23 $self->{connections}->{$conn->id} = $conn;
47              
48 3         16 DEBUG && warn "Added connection '" . $conn->id . "'\n";
49              
50 3         14 return $cb->($conn);
51             }
52              
53             sub remove_connection {
54 1     1 1 3 my $self = shift;
55 1         2 my ($conn, $cb) = @_;
56              
57 1 50       6 my $id = blessed $conn ? $conn->id : $conn;
58              
59 1         4 delete $self->{connections}->{$id};
60 1         2 foreach my $room (keys %{$self->{revrooms}{$id}}) {
  1         8  
61 0         0 delete $self->{rooms}{$room}{$id};
62             }
63 1         3 delete $self->{revrooms}{$id};
64              
65 1         4 DEBUG && warn "Removed connection '" . $id . "'\n";
66              
67 1 50       6 return $cb->() if $cb;
68             }
69              
70             sub room_join {
71 0     0 0 0 my $self = shift;
72 0         0 my $room = shift;
73 0         0 my $conn = shift;
74              
75 0 0       0 my $id = blessed $conn ? $conn->id : $conn;
76 0         0 $conn = $self->{connections}->{$id};
77              
78 0         0 $self->{rooms}{$room}{$id} = $conn;
79 0         0 $self->{revrooms}{$id}{$room} = $conn;
80 0         0 return $conn;
81             }
82              
83             sub room_leave {
84 0     0 0 0 my $self = shift;
85 0         0 my $room = shift;
86 0         0 my $conn = shift;
87 0         0 my ($subrooms) = @_;
88              
89 0 0       0 my $id = blessed $conn ? $conn->id : $conn;
90              
91 0 0       0 if ($subrooms) {
92 0         0 DEBUG && warn "Deleting '$id' subrooms of '$room'\n";
93 0         0 foreach my $subroom (keys %{$self->{revrooms}{$id}}) {
  0         0  
94 0 0       0 if ($subroom =~ /^\Q$room\E/) {
95 0         0 delete $self->{rooms}{$subroom}{$id};
96 0         0 delete $self->{revrooms}{$id}{$subroom};
97             }
98             }
99             }
100             else {
101 0         0 DEBUG && warn "Deleting just '$id' room '$room'\n";
102 0         0 delete $self->{rooms}{$room}{$id};
103 0         0 delete $self->{revrooms}{$id}{$room};
104             }
105 0         0 return $conn;
106             }
107              
108             sub send_raw {
109 4     4 0 8 my $self = shift;
110 4         16 my ($msg) = {@_};
111              
112 4 50       20 if (defined $msg->{id}) {
113              
114             # Message directly to a connection.
115 0         0 my $conn = $self->find_local_connection($msg->{id});
116 0 0       0 if (defined $conn) {
117              
118             # Send the message here and now.
119 0         0 DEBUG && warn "Sending message to $msg->{id}\n";
120 0 0       0 if (defined $msg->{bytes}) {
121 0         0 $conn->write($msg->{bytes});
122             }
123             else {
124 0         0 $conn->send($msg->{message});
125             }
126             }
127 0         0 return $conn;
128             }
129              
130 0         0 my @members =
131             defined $msg->{room}
132 4 50       34 ? values %{$self->{rooms}{$msg->{room}}}
133             : $self->_connections;
134              
135 4         14 foreach my $conn (@members) {
136 0 0 0     0 next unless blessed $conn && $conn->is_connected;
137 0 0 0     0 next if defined $msg->{invoker} && $conn->id eq $msg->{invoker}->id;
138              
139 0         0 DEBUG && warn "Sending message to " . $conn->id . "\n";
140 0         0 $conn->socket->send($msg->{message});
141             }
142              
143 4         17 return $self;
144             }
145              
146             sub send {
147 2     2 1 5 my $self = shift;
148              
149 2         6 return $self->send_raw(message => $_[0]);
150             }
151              
152             sub broadcast {
153 2     2 1 5 my $self = shift;
154 2         5 my $invoker = shift;
155              
156 2         11 return $self->send_raw(message => $_[0], invoker => $invoker);
157             }
158              
159             sub _connections {
160 4     4   7 my $self = shift;
161              
162 4         6 return values %{$self->{connections}};
  4         16  
163             }
164              
165             sub _build_connection {
166 3     3   5 my $self = shift;
167              
168             return PocketIO::Connection->new(
169             @_,
170             pool => $self,
171 0     0     on_connect_failed => sub { $self->remove_connection(@_) },
172             on_reconnect_failed => sub {
173 0     0     my $conn = shift;
174              
175 0           $conn->disconnected;
176              
177 0           $self->remove_connection($conn);
178             }
179 3         35 );
180             }
181              
182             1;
183             __END__