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__ |