File Coverage

blib/lib/POE/Component/Server/Time.pm
Criterion Covered Total %
statement 53 54 98.1
branch 7 14 50.0
condition 3 9 33.3
subroutine 13 14 92.8
pod 1 1 100.0
total 77 92 83.7


line stmt bran cond sub pod time code
1             # $Id: Time.pm,v 1.1.1.1 2005/01/27 15:36:15 chris Exp $
2             #
3             # POE::Component::Server::Time, by Chris 'BinGOs' Williams
4             #
5             # This module may be used, modified, and distributed under the same
6             # terms as Perl itself. Please see the license that came with your Perl
7             # distribution for details.
8             #
9              
10             package POE::Component::Server::Time;
11              
12 3     3   132886 use strict;
  3         8  
  3         135  
13 3     3   17 use warnings;
  3         8  
  3         280  
14 3     3   18 use Carp;
  3         11  
  3         315  
15 3     3   8661 use POE;
  3         284502  
  3         20  
16 3     3   414867 use Socket;
  3         7  
  3         7527  
17 3     3   26 use base qw(POE::Component::Server::Echo);
  3         6  
  3         3205  
18 3     3   81260 use vars qw($VERSION);
  3         8  
  3         111  
19              
20 3     3   15 use constant DATAGRAM_MAXLEN => 1024;
  3         5  
  3         130  
21 3     3   15 use constant DEFAULT_PORT => 37;
  3         6  
  3         1645  
22              
23             $VERSION = '1.14';
24              
25             sub spawn {
26 2     2 1 29 my $package = shift;
27 2 50       11 croak "$package requires an even number of parameters" if @_ & 1;
28              
29 2         13 my %parms = @_;
30              
31 2 50 33     22 $parms{'Alias'} = 'Time-Server' unless defined $parms{'Alias'} and $parms{'Alias'};
32 2 50 33     14 $parms{'tcp'} = 1 unless defined $parms{'tcp'} and $parms{'tcp'} == 0;
33 2 50 33     11 $parms{'udp'} = 1 unless defined $parms{'udp'} and $parms{'udp'} == 0;
34              
35 2         8 my $self = bless { }, $package;
36              
37 2         27 $self->{CONFIG} = \%parms;
38              
39 2 50       37 POE::Session->create(
40             object_states => [
41             $self => { _start => '_server_start',
42             _stop => '_server_stop',
43             shutdown => '_server_close' },
44             $self => [ qw(_accept_new_client _accept_failed _client_input _client_error _client_flushed _get_datagram) ],
45             ],
46             ( ref $parms{'options'} eq 'HASH' ? ( options => $parms{'options'} ) : () ),
47             );
48              
49 2         4630 return $self;
50             }
51              
52             sub _accept_new_client {
53 1     1   2172 my ($kernel,$self,$socket,$peeraddr,$peerport,$wheel_id) = @_[KERNEL,OBJECT,ARG0 .. ARG3];
54 1         9 $peeraddr = inet_ntoa($peeraddr);
55              
56 1         12 my $wheel = POE::Wheel::ReadWrite->new (
57             Handle => $socket,
58             Filter => POE::Filter::Line->new(),
59             InputEvent => '_client_input',
60             ErrorEvent => '_client_error',
61             FlushedEvent => '_client_flushed',
62             );
63              
64 1         375 $self->{Clients}->{ $wheel->ID() } = { Wheel => $wheel, peeraddr => $peeraddr, peerport => $peerport };;
65 1         14 $wheel->put( time );
66 1         85 undef;
67             }
68              
69             sub _client_input {
70 0     0   0 undef;
71             }
72              
73             sub _client_flushed {
74 1     1   1556 my ($kernel,$self,$wheel_id) = @_[KERNEL,OBJECT,ARG0];
75 1         7 delete $self->{Clients}->{ $wheel_id }->{Wheel};
76 1         193 delete $self->{Clients}->{ $wheel_id };
77 1         3 undef;
78             }
79              
80             sub _get_datagram {
81 1     1   2012 my ( $kernel, $self, $socket ) = @_[ KERNEL, OBJECT, ARG0 ];
82              
83 1         23 my $remote_address = recv( $socket, my $message = "", DATAGRAM_MAXLEN, 0 );
84 1 50       6 return unless defined $remote_address;
85              
86 1         5 my $output = time();
87 1 50       18 send( $socket, $output, 0, $remote_address ) == length( $output )
88             or warn "Trouble sending response: $!";
89 1         4 undef;
90             }
91              
92             1;
93             __END__