File Coverage

blib/lib/POE/Component/Server/POP3.pm
Criterion Covered Total %
statement 133 194 68.5
branch 30 76 39.4
condition 5 15 33.3
subroutine 22 33 66.6
pod 9 10 90.0
total 199 328 60.6


line stmt bran cond sub pod time code
1             package POE::Component::Server::POP3;
2             $POE::Component::Server::POP3::VERSION = '0.12';
3             #ABSTRACT: A POE framework for authoring POP3 servers
4              
5 1     1   102931 use strict;
  1         1  
  1         23  
6 1     1   3 use warnings;
  1         1  
  1         28  
7 1     1   3 use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::Line);
  1         1  
  1         11  
8 1     1   13766 use base qw(POE::Component::Pluggable);
  1         1  
  1         440  
9 1     1   4229 use POE::Component::Pluggable::Constants qw(:ALL);
  1         1  
  1         88  
10 1     1   5 use Socket;
  1         1  
  1         2182  
11              
12             sub spawn {
13 1     1 1 673 my $package = shift;
14 1         3 my %opts = @_;
15 1         7 $opts{lc $_} = delete $opts{$_} for keys %opts;
16 1         2 my $options = delete $opts{options};
17 1 50       5 $opts{version} = join('-', __PACKAGE__, $POE::Component::Server::POP3::VERSION ) unless $opts{version};
18 1 50 33     6 $opts{handle_connects} = 1 unless defined $opts{handle_connects} and !$opts{handle_connects};
19 1 50       3 $opts{hostname} = 'localhost' unless defined $opts{hostname};
20 1         2 my $self = bless \%opts, $package;
21 1         12 $self->_pluggable_init( prefix => 'pop3d_', types => [ 'POP3D', 'POP3C' ], debug => 1 );
22 1 50       47 $self->{session_id} = POE::Session->create(
23             object_states => [
24             $self => { shutdown => '_shutdown',
25             send_event => '__send_event',
26             send_to_client => '_send_to_client',
27             disconnect => '_disconnect',
28             },
29             $self => [ qw(_start register unregister _accept_client _accept_failed _conn_input _conn_error _conn_flushed _conn_alarm _send_to_client __send_event _disconnect) ],
30             ],
31             heap => $self,
32             ( ref($options) eq 'HASH' ? ( options => $options ) : () ),
33             )->ID();
34 1         82 return $self;
35             }
36              
37             sub session_id {
38 1     1 1 2 return $_[0]->{session_id};
39             }
40              
41             sub getsockname {
42 1 50   1 1 945 return unless $_[0]->{listener};
43 1         5 return $_[0]->{listener}->getsockname();
44             }
45              
46             sub _conn_exists {
47 8     8   9 my ($self,$wheel_id) = @_;
48 8 50 33     32 return 0 unless $wheel_id and defined $self->{clients}->{ $wheel_id };
49 8         19 return 1;
50             }
51              
52             sub _valid_cmd {
53 2     2   2 my $self = shift;
54 2   50     3 my $cmd = shift || return;
55 2         3 $cmd = lc $cmd;
56 2 100       1 return 0 unless grep { $_ eq $cmd } @{ $self->{cmds} };
  24         27  
  2         3  
57 1         2 return 1;
58             }
59              
60             sub shutdown {
61 1     1 1 1349 my $self = shift;
62 1         4 $poe_kernel->post( $self->{session_id}, 'shutdown' );
63             }
64              
65             sub _start {
66 1     1   212 my ($kernel,$self,$sender) = @_[KERNEL,OBJECT,SENDER];
67 1         3 $self->{session_id} = $_[SESSION]->ID();
68 1 50       5 if ( $self->{alias} ) {
69 0         0 $kernel->alias_set( $self->{alias} );
70             }
71             else {
72 1         5 $kernel->refcount_increment( $self->{session_id} => __PACKAGE__ );
73             }
74 1 50       26 if ( $kernel != $sender ) {
75 1         3 my $sender_id = $sender->ID;
76 1         4 $self->{events}->{'pop3d_all'}->{$sender_id} = $sender_id;
77 1         7 $self->{sessions}->{$sender_id}->{'ref'} = $sender_id;
78 1         4 $kernel->refcount_increment($sender_id, __PACKAGE__);
79 1         16 $kernel->post( $sender, 'pop3d_registered', $self );
80 1         83 $kernel->detach_myself();
81             }
82              
83 1         88 $self->{filter} = POE::Filter::Line->new( Literal => "\015\012" );
84              
85 1         46 $self->{cmds} = [ qw(stat list retr dele noop rset top uidl user pass apop quit) ];
86              
87             $self->{listener} = POE::Wheel::SocketFactory->new(
88             ( defined $self->{address} ? ( BindAddress => $self->{address} ) : () ),
89 1 50       13 ( defined $self->{port} ? ( BindPort => $self->{port} ) : ( BindPort => 110 ) ),
    50          
90             SuccessEvent => '_accept_client',
91             FailureEvent => '_accept_failed',
92             SocketDomain => AF_INET, # Sets the socket() domain
93             SocketType => SOCK_STREAM, # Sets the socket() type
94             SocketProtocol => 'tcp', # Sets the socket() protocol
95             Reuse => 'on', # Lets the port be reused
96             );
97              
98 1         405 return;
99             }
100              
101             sub _accept_client {
102 1     1   594 my ($kernel,$self,$socket,$peeraddr,$peerport) = @_[KERNEL,OBJECT,ARG0..ARG2];
103 1         11 my $sockaddr = inet_ntoa( ( unpack_sockaddr_in ( CORE::getsockname $socket ) )[1] );
104 1         5 my $sockport = ( unpack_sockaddr_in ( CORE::getsockname $socket ) )[0];
105 1         4 $peeraddr = inet_ntoa( $peeraddr );
106              
107             my $wheel = POE::Wheel::ReadWrite->new(
108             Handle => $socket,
109             Filter => $self->{filter},
110 1         9 InputEvent => '_conn_input',
111             ErrorEvent => '_conn_error',
112             FlushedEvent => '_conn_flushed',
113             );
114              
115 1 50       227 return unless $wheel;
116              
117 1         4 my $id = $wheel->ID();
118 1         10 $self->{clients}->{ $id } =
119             {
120             wheel => $wheel,
121             peeraddr => $peeraddr,
122             peerport => $peerport,
123             sockaddr => $sockaddr,
124             sockport => $sockport,
125             };
126 1         4 $self->_send_event( 'pop3d_connection', $id, $peeraddr, $peerport, $sockaddr, $sockport );
127              
128 1   50     7 $self->{clients}->{ $id }->{alarm} = $kernel->delay_set( '_conn_alarm', $self->{time_out} || 300, $id );
129 1         62 return;
130             }
131              
132             sub _accept_failed {
133 0     0   0 my ($kernel,$self,$operation,$errnum,$errstr,$wheel_id) = @_[KERNEL,OBJECT,ARG0..ARG3];
134 0         0 warn "Wheel $wheel_id generated $operation error $errnum: $errstr\n";
135 0         0 delete $self->{listener};
136 0         0 $self->_send_event( 'pop3d_listener_failed', $operation, $errnum, $errstr );
137 0         0 return;
138             }
139              
140             sub _conn_input {
141 2     2   1601 my ($kernel,$self,$input,$id) = @_[KERNEL,OBJECT,ARG0,ARG1];
142 2 50       4 return unless $self->_conn_exists( $id );
143 2   50     12 $kernel->delay_adjust( $self->{clients}->{ $id }->{alarm}, $self->{time_out} || 300 );
144 2         119 $input =~ s/^\s+//g;
145 2         4 $input =~ s/\s+$//g;
146 2         5 my @args = split /\s+/, $input, 2;
147 2         3 my $cmd = shift @args;
148 2 50       5 return unless $cmd;
149 2 100       4 unless ( $self->_valid_cmd( $cmd ) ) {
150 1         9 $self->send_to_client( $id, '-ERR' );
151 1         6 return;
152             }
153 1         2 $cmd = lc $cmd;
154 1 50       5 $self->{clients}->{ $id }->{quit} = 1 if $cmd eq 'quit';
155 1         3 $self->_send_event( 'pop3d_cmd_' . $cmd, $id, @args );
156 1         2 return;
157             }
158              
159             sub _conn_error {
160 0     0   0 my ($self,$errstr,$id) = @_[OBJECT,ARG2,ARG3];
161 0 0       0 return unless $self->_conn_exists( $id );
162 0         0 delete $self->{clients}->{ $id };
163 0         0 $self->_send_event( 'pop3d_disconnected', $id );
164 0         0 return;
165             }
166              
167             sub _conn_flushed {
168 3     3   1317 my ($self,$id) = @_[OBJECT,ARG0];
169 3 50       5 return unless $self->_conn_exists( $id );
170 3 100       9 return unless $self->{clients}->{ $id }->{quit};
171 1         6 delete $self->{clients}->{ $id };
172 1         150 $self->_send_event( 'pop3d_disconnected', $id );
173 1         2 return;
174             }
175              
176             sub _conn_alarm {
177 0     0   0 my ($kernel,$self,$id) = @_[KERNEL,OBJECT,ARG0];
178 0 0       0 return unless $self->_conn_exists( $id );
179 0         0 delete $self->{clients}->{ $id };
180 0         0 $self->_send_event( 'pop3d_disconnected', $id );
181 0         0 return;
182             }
183              
184             sub _shutdown {
185 1     1   188 my ($kernel,$self) = @_[KERNEL,OBJECT];
186 1         4 delete $self->{listener};
187 1         108 delete $self->{clients};
188 1         4 $kernel->alarm_remove_all();
189 1         56 $kernel->alias_remove( $_ ) for $kernel->alias_list();
190 1 50       25 $kernel->refcount_decrement( $self->{session_id} => __PACKAGE__ ) unless $self->{alias};
191 1         36 $self->_pluggable_destroy();
192 1         22 $self->_unregister_sessions();
193 1         23 return;
194             }
195              
196             sub register {
197 0     0 1 0 my ($kernel, $self, $session, $sender, @events) =
198             @_[KERNEL, OBJECT, SESSION, SENDER, ARG0 .. $#_];
199              
200 0 0       0 unless (@events) {
201 0         0 warn "register: Not enough arguments";
202 0         0 return;
203             }
204              
205 0         0 my $sender_id = $sender->ID();
206              
207 0         0 foreach (@events) {
208 0 0       0 $_ = "pop3d_" . $_ unless /^_/;
209 0         0 $self->{events}->{$_}->{$sender_id} = $sender_id;
210 0         0 $self->{sessions}->{$sender_id}->{'ref'} = $sender_id;
211 0 0 0     0 unless ($self->{sessions}->{$sender_id}->{refcnt}++ or $session == $sender) {
212 0         0 $kernel->refcount_increment($sender_id, __PACKAGE__);
213             }
214             }
215              
216 0         0 $kernel->post( $sender, 'pop3d_registered', $self );
217 0         0 return;
218             }
219              
220             sub unregister {
221 0     0 1 0 my ($kernel, $self, $session, $sender, @events) =
222             @_[KERNEL, OBJECT, SESSION, SENDER, ARG0 .. $#_];
223              
224 0 0       0 unless (@events) {
225 0         0 warn "unregister: Not enough arguments";
226 0         0 return;
227             }
228              
229 0         0 $self->_unregister($session,$sender,@events);
230 0         0 undef;
231             }
232              
233             sub _unregister {
234 0     0   0 my ($self,$session,$sender) = splice @_,0,3;
235 0         0 my $sender_id = $sender->ID();
236              
237 0         0 foreach (@_) {
238 0 0       0 $_ = "pop3d_" . $_ unless /^_/;
239 0         0 my $blah = delete $self->{events}->{$_}->{$sender_id};
240 0 0       0 unless ( $blah ) {
241 0         0 warn "$sender_id hasn't registered for '$_' events\n";
242 0         0 next;
243             }
244 0 0       0 if (--$self->{sessions}->{$sender_id}->{refcnt} <= 0) {
245 0         0 delete $self->{sessions}->{$sender_id};
246 0 0       0 unless ($session == $sender) {
247 0         0 $poe_kernel->refcount_decrement($sender_id, __PACKAGE__);
248             }
249             }
250             }
251 0         0 undef;
252             }
253              
254             sub _unregister_sessions {
255 1     1   3 my $self = shift;
256 1         2 my $pop3d_id = $self->session_id();
257 1         1 foreach my $session_id ( keys %{ $self->{sessions} } ) {
  1         3  
258 1 50       4 if (--$self->{sessions}->{$session_id}->{refcnt} <= 0) {
259 1         6 delete $self->{sessions}->{$session_id};
260 1 50       4 $poe_kernel->refcount_decrement($session_id, __PACKAGE__)
261             unless ( $session_id eq $pop3d_id );
262             }
263             }
264             }
265              
266             sub __send_event {
267 0     0   0 my( $self, $event, @args ) = @_[ OBJECT, ARG0, ARG1 .. $#_ ];
268 0         0 $self->_send_event( $event, @args );
269 0         0 return;
270             }
271              
272             sub _pluggable_event {
273 0     0   0 my $self = shift;
274 0         0 $poe_kernel->post( $self->{session_id}, '__send_event', @_ );
275             }
276              
277             sub send_event {
278 0     0 1 0 my $self = shift;
279 0         0 $poe_kernel->post( $self->{session_id}, '__send_event', @_ );
280             }
281              
282             sub _send_event {
283 3     3   4 my $self = shift;
284 3         17 my ($event, @args) = @_;
285 3         2 my $kernel = $POE::Kernel::poe_kernel;
286 3         9 my $session = $kernel->get_active_session()->ID();
287 3         12 my %sessions;
288              
289             my @extra_args;
290              
291 3 50       13 return 1 if $self->_pluggable_process( 'POP3D', $event, \( @args ), \@extra_args ) == PLUGIN_EAT_ALL;
292              
293 3 50       85 push @args, @extra_args if scalar @extra_args;
294              
295 3         3 $sessions{$_} = $_ for (values %{$self->{events}->{'pop3d_all'}}, values %{$self->{events}->{$event}});
  3         6  
  3         10  
296              
297 3         9 $kernel->post( $_ => $event => @args ) for values %sessions;
298 3         174 undef;
299             }
300              
301             sub disconnect {
302 0     0 1 0 my $self = shift;
303 0         0 $poe_kernel->call( $self->{session_id}, '_disconnect', @_ );
304             }
305              
306             sub _disconnect {
307 0     0   0 my ($kernel,$self,$id) = @_[KERNEL,OBJECT,ARG0];
308 0 0       0 return unless $self->_conn_exists( $id );
309 0         0 $self->{clients}->{ $id }->{quit} = 1;
310 0         0 return 1;
311             }
312              
313             sub send_to_client {
314 3     3 1 346 my $self = shift;
315 3         12 $poe_kernel->call( $self->{session_id}, '_send_to_client', @_ );
316             }
317              
318             sub _send_to_client {
319 3     3   96 my ($kernel,$self,$id,$output) = @_[KERNEL,OBJECT,ARG0..ARG1];
320 3 50       5 return unless $self->_conn_exists( $id );
321 3 50       10 return unless defined $output;
322              
323 3 50       9 return 1 if $self->_pluggable_process( 'POP3C', 'response', $id, \$output ) == PLUGIN_EAT_ALL;
324              
325 3         91 $self->{clients}->{ $id }->{wheel}->put($output);
326 3         142 return 1;
327             }
328              
329             sub POP3D_connection {
330 1     1 0 76 my ($self,$pop3d) = splice @_, 0, 2;
331 1         5 my $id = ${ $_[0] };
  1         1  
332 1 50       4 return PLUGIN_EAT_NONE unless $self->{handle_connects};
333 1         5 $self->send_to_client( $id, join ' ', '+OK POP3', $self->{hostname}, $self->{version}, 'server ready' );
334 1         6 return PLUGIN_EAT_NONE;
335             }
336              
337             'poppet';
338              
339             __END__