line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POE::Component::Client::BigBrother; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
22907
|
use strict; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
160
|
|
4
|
2
|
|
|
2
|
|
17
|
use warnings; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
107
|
|
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
32
|
use Carp; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
364
|
|
7
|
2
|
|
|
2
|
|
1594
|
use POE qw< Component::Client::TCP >; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '1.00'; |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# |
13
|
|
|
|
|
|
|
# send() |
14
|
|
|
|
|
|
|
# ---- |
15
|
|
|
|
|
|
|
sub send { |
16
|
|
|
|
|
|
|
my ($class, %param) = @_; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# check for mandatory parameters |
19
|
|
|
|
|
|
|
my @mandatory = qw< host event command_type command_fields >; |
20
|
|
|
|
|
|
|
for my $name (@mandatory) { |
21
|
|
|
|
|
|
|
croak "error: $class requires a '$name' parameter" |
22
|
|
|
|
|
|
|
unless $param{$name}; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# default values |
26
|
|
|
|
|
|
|
$param{port} = 1984 unless defined $param{port}; |
27
|
|
|
|
|
|
|
$param{timeout} = 10 unless defined $param{timeout}; |
28
|
|
|
|
|
|
|
$param{retry} = 2 unless defined $param{retry}; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# aliases |
31
|
|
|
|
|
|
|
my $field = $param{command_fields}; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# check for mandatory fields common to all commands |
34
|
|
|
|
|
|
|
@mandatory = qw< host service message >; |
35
|
|
|
|
|
|
|
for my $name (@mandatory) { |
36
|
|
|
|
|
|
|
croak "error: '$param{command_type}' command requires a '$name' field" |
37
|
|
|
|
|
|
|
unless $field->{$name}; |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# check and adapt some values to Big Brother message format |
41
|
|
|
|
|
|
|
(my $host = $field->{host}) =~ s/\./,/g; |
42
|
|
|
|
|
|
|
my $service = $field->{service}; |
43
|
|
|
|
|
|
|
my $color = $field->{color}; |
44
|
|
|
|
|
|
|
my $offset = $field->{offset} ? "+$field->{offset}" : ""; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# construct the Big Brother message |
47
|
|
|
|
|
|
|
if ($param{command_type} eq "status" or $param{command_type} eq "page") { |
48
|
|
|
|
|
|
|
$param{message} = "$param{command_type}$offset" |
49
|
|
|
|
|
|
|
. " $host.$service $color $field->{message}"; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
elsif ($param{command_type} eq "disable") { |
52
|
|
|
|
|
|
|
$param{message} = "$param{command_type}$offset" |
53
|
|
|
|
|
|
|
. " $host.$service $field->{duration} $field->{message}"; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
elsif ($param{command_type} eq "enable") { |
56
|
|
|
|
|
|
|
$param{message} = "$param{command_type}$offset" |
57
|
|
|
|
|
|
|
. " $host.$service $field->{message}"; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
elsif ($param{command_type} eq "event") { |
60
|
|
|
|
|
|
|
$field->{activation} ||= time(); |
61
|
|
|
|
|
|
|
$param{message} = join "", "event\n", |
62
|
|
|
|
|
|
|
map { "$_: $field->{$_}\n" } sort keys %$field; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
else { |
65
|
|
|
|
|
|
|
croak "error: Unknown command type '$param{command_type}'" |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# spawn a PoCo::Client::TCP to send the message |
69
|
|
|
|
|
|
|
POE::Component::Client::TCP->new( |
70
|
|
|
|
|
|
|
RemoteAddress => $param{host}, |
71
|
|
|
|
|
|
|
RemotePort => $param{port}, |
72
|
|
|
|
|
|
|
ConnectTimeout => $param{timeout}, |
73
|
|
|
|
|
|
|
Args => [ { %param } ], |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
Started => sub { |
76
|
|
|
|
|
|
|
my ($kernel, $heap, $sender, $param) |
77
|
|
|
|
|
|
|
= @_[ KERNEL, HEAP, SENDER, ARG0 ]; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
my $sender_id; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# resolve sender session |
82
|
|
|
|
|
|
|
if ($param->{session}) { |
83
|
|
|
|
|
|
|
if (my $ref = $kernel->alias_resolve($param->{session})) { |
84
|
|
|
|
|
|
|
$sender_id = $ref->ID; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
else { |
87
|
|
|
|
|
|
|
croak "error: Could not resolve 'session' to a valid " |
88
|
|
|
|
|
|
|
. "POE session"; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
else { |
92
|
|
|
|
|
|
|
$sender_id = $sender->ID; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# store some information in the heap |
96
|
|
|
|
|
|
|
$heap->{sender_id} = $sender_id; # sender session ID |
97
|
|
|
|
|
|
|
$heap->{retry} = $param->{retry} + 1; # number of retries left |
98
|
|
|
|
|
|
|
$heap->{param} = $param; # input parameters |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# store the future response in the heap |
101
|
|
|
|
|
|
|
$heap->{response} = { |
102
|
|
|
|
|
|
|
host => $param->{host}, |
103
|
|
|
|
|
|
|
message => $param->{message}, |
104
|
|
|
|
|
|
|
context => $param->{context}, |
105
|
|
|
|
|
|
|
success => 1, |
106
|
|
|
|
|
|
|
}; |
107
|
|
|
|
|
|
|
}, |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
Connected => sub { |
110
|
|
|
|
|
|
|
my ($kernel, $heap) = @_[ KERNEL, HEAP ]; |
111
|
|
|
|
|
|
|
my $data = $heap->{param}{message}; |
112
|
|
|
|
|
|
|
$heap->{server}->put($data); # send the message |
113
|
|
|
|
|
|
|
$kernel->yield("shutdown"); # close the connection |
114
|
|
|
|
|
|
|
}, |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
ServerInput => sub {}, # no input is expected from the server |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
Disconnected => sub { |
119
|
|
|
|
|
|
|
my ($kernel, $heap) = @_[ KERNEL, HEAP ]; |
120
|
|
|
|
|
|
|
$kernel->yield("_send_response"); |
121
|
|
|
|
|
|
|
}, |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
ConnectError => sub { |
124
|
|
|
|
|
|
|
my ($kernel, $heap, $op, $errno, $errstr) |
125
|
|
|
|
|
|
|
= @_[ KERNEL, HEAP, ARG0..ARG2 ]; |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
$heap->{retry}--; |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
if ($heap->{retry} > 0) { |
130
|
|
|
|
|
|
|
$kernel->yield("reconnect"); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
else { |
133
|
|
|
|
|
|
|
$heap->{response}{success} = 0; |
134
|
|
|
|
|
|
|
$heap->{response}{error} = "$op error $errno: $errstr"; |
135
|
|
|
|
|
|
|
$kernel->yield("_send_response"); |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
}, |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
InlineStates => { |
140
|
|
|
|
|
|
|
_send_response => sub { |
141
|
|
|
|
|
|
|
my ($kernel, $heap) = @_[ KERNEL, HEAP ]; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
my $session = $heap->{sender_id}; |
144
|
|
|
|
|
|
|
my $event = $heap->{param}{event}; |
145
|
|
|
|
|
|
|
my $response= $heap->{response}; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# send the response to the send session |
148
|
|
|
|
|
|
|
$kernel->post($session, $event, $response); |
149
|
|
|
|
|
|
|
}, |
150
|
|
|
|
|
|
|
}, |
151
|
|
|
|
|
|
|
); |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
1; |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
__END__ |