line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Slack::RTM::Bot::Client;
|
2
|
|
|
|
|
|
|
|
3
|
8
|
|
|
8
|
|
59
|
use strict;
|
|
8
|
|
|
|
|
19
|
|
|
8
|
|
|
|
|
246
|
|
4
|
8
|
|
|
8
|
|
45
|
use warnings;
|
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
223
|
|
5
|
|
|
|
|
|
|
|
6
|
8
|
|
|
8
|
|
40
|
use JSON;
|
|
8
|
|
|
|
|
18
|
|
|
8
|
|
|
|
|
42
|
|
7
|
8
|
|
|
8
|
|
4804
|
use Encode;
|
|
8
|
|
|
|
|
123323
|
|
|
8
|
|
|
|
|
654
|
|
8
|
8
|
|
|
8
|
|
5041
|
use Data::Dumper;
|
|
8
|
|
|
|
|
50708
|
|
|
8
|
|
|
|
|
555
|
|
9
|
|
|
|
|
|
|
|
10
|
8
|
|
|
8
|
|
4430
|
use HTTP::Request::Common qw(POST GET);
|
|
8
|
|
|
|
|
165310
|
|
|
8
|
|
|
|
|
666
|
|
11
|
8
|
|
|
8
|
|
5746
|
use LWP::UserAgent;
|
|
8
|
|
|
|
|
208433
|
|
|
8
|
|
|
|
|
352
|
|
12
|
8
|
|
|
8
|
|
4198
|
use LWP::Protocol::https;
|
|
8
|
|
|
|
|
743173
|
|
|
8
|
|
|
|
|
439
|
|
13
|
|
|
|
|
|
|
|
14
|
8
|
|
|
8
|
|
4153
|
use Protocol::WebSocket::Client;
|
|
8
|
|
|
|
|
181270
|
|
|
8
|
|
|
|
|
313
|
|
15
|
8
|
|
|
8
|
|
77
|
use IO::Socket::SSL qw/SSL_VERIFY_NONE/;
|
|
8
|
|
|
|
|
23
|
|
|
8
|
|
|
|
|
81
|
|
16
|
|
|
|
|
|
|
|
17
|
8
|
|
|
8
|
|
4603
|
use Slack::RTM::Bot::Information;
|
|
8
|
|
|
|
|
34
|
|
|
8
|
|
|
|
|
381
|
|
18
|
8
|
|
|
8
|
|
3371
|
use Slack::RTM::Bot::Response;
|
|
8
|
|
|
|
|
42
|
|
|
8
|
|
|
|
|
16069
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
my $ua = LWP::UserAgent->new(
|
21
|
|
|
|
|
|
|
ssl_opts => {
|
22
|
|
|
|
|
|
|
verify_hostname => 0,
|
23
|
|
|
|
|
|
|
SSL_verify_mode => SSL_VERIFY_NONE
|
24
|
|
|
|
|
|
|
}
|
25
|
|
|
|
|
|
|
);
|
26
|
|
|
|
|
|
|
$ua->agent('Slack::RTM::Bot');
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub new {
|
29
|
3
|
|
|
3
|
0
|
30
|
my $pkg = shift;
|
30
|
3
|
|
|
|
|
13
|
my $self = {
|
31
|
|
|
|
|
|
|
@_
|
32
|
|
|
|
|
|
|
};
|
33
|
3
|
50
|
|
|
|
13
|
die "token is required." unless $self->{token};
|
34
|
3
|
|
|
|
|
15
|
return bless $self, $pkg;
|
35
|
|
|
|
|
|
|
}
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub connect {
|
38
|
1
|
|
|
1
|
0
|
2
|
my $self = shift;
|
39
|
1
|
|
|
|
|
3
|
my ($token) = @_;
|
40
|
|
|
|
|
|
|
|
41
|
1
|
|
|
|
|
6
|
my $res = $ua->request(POST 'https://slack.com/api/rtm.start', [ token => $token ]);
|
42
|
1
|
|
|
|
|
309444
|
my $content;
|
43
|
1
|
|
|
|
|
3
|
eval {
|
44
|
1
|
|
|
|
|
8
|
$content = JSON::from_json($res->content);
|
45
|
|
|
|
|
|
|
};
|
46
|
1
|
50
|
|
|
|
81
|
if ($@) {
|
47
|
0
|
|
|
|
|
0
|
die 'connect response fail:'.Dumper $res->content;
|
48
|
|
|
|
|
|
|
}
|
49
|
1
|
50
|
|
|
|
52
|
die 'connect response fail: '.$res->content unless ($content->{ok});
|
50
|
|
|
|
|
|
|
|
51
|
0
|
|
|
|
|
0
|
$self->{info} = Slack::RTM::Bot::Information->new(%{$content});
|
|
0
|
|
|
|
|
0
|
|
52
|
0
|
|
|
|
|
0
|
$res = $ua->request(POST 'https://slack.com/api/conversations.list ', [ token => $token ]);
|
53
|
0
|
|
|
|
|
0
|
eval {
|
54
|
0
|
|
|
|
|
0
|
$content = JSON::decode_json($res->content);
|
55
|
|
|
|
|
|
|
};
|
56
|
0
|
0
|
|
|
|
0
|
if ($@) {
|
57
|
0
|
|
|
|
|
0
|
die 'connect response fail:'.Dumper $res->content;
|
58
|
|
|
|
|
|
|
}
|
59
|
0
|
0
|
|
|
|
0
|
die 'connect response fail: '.$res->content unless ($content->{ok});
|
60
|
|
|
|
|
|
|
|
61
|
0
|
|
|
|
|
0
|
for my $im (@{$content->{channels}}) {
|
|
0
|
|
|
|
|
0
|
|
62
|
0
|
|
|
|
|
0
|
$self->{info}->{channels}->{$im->{id}} = { %$im, name => '@'.$im->{name} };
|
63
|
|
|
|
|
|
|
}
|
64
|
0
|
|
|
|
|
0
|
$self->_connect;
|
65
|
|
|
|
|
|
|
}
|
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub _connect {
|
68
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
69
|
0
|
|
|
|
|
0
|
my ($host) = $self->{info}->{url} =~ m{wss://(.+)/websocket};
|
70
|
0
|
|
|
|
|
0
|
my $socket = IO::Socket::SSL->new(
|
71
|
|
|
|
|
|
|
SSL_verify_mode => SSL_VERIFY_NONE,
|
72
|
|
|
|
|
|
|
PeerHost => $host,
|
73
|
|
|
|
|
|
|
PeerPort => 443
|
74
|
|
|
|
|
|
|
);
|
75
|
0
|
|
|
|
|
0
|
$socket->blocking(0);
|
76
|
0
|
|
|
|
|
0
|
$socket->connect;
|
77
|
|
|
|
|
|
|
|
78
|
0
|
|
|
|
|
0
|
my $ws_client = Protocol::WebSocket::Client->new(url => $self->{info}->{url});
|
79
|
0
|
0
|
|
|
|
0
|
$ws_client->{hs}->req->{max_message_size} = $self->{options}->{max_message_size} if $self->{options}->{max_message_size};
|
80
|
0
|
0
|
|
|
|
0
|
$ws_client->{hs}->res->{max_message_size} = $self->{options}->{max_message_size} if $self->{options}->{max_message_size};
|
81
|
|
|
|
|
|
|
$ws_client->on(read => sub {
|
82
|
0
|
|
|
0
|
|
0
|
my ($cli, $buffer) = @_;
|
83
|
0
|
|
|
|
|
0
|
$self->_listen($buffer);
|
84
|
0
|
|
|
|
|
0
|
});
|
85
|
|
|
|
|
|
|
$ws_client->on(write => sub {
|
86
|
0
|
|
|
0
|
|
0
|
my ($cli, $buffer) = @_;
|
87
|
0
|
|
|
|
|
0
|
syswrite $socket, $buffer;
|
88
|
0
|
|
|
|
|
0
|
});
|
89
|
|
|
|
|
|
|
$ws_client->on(connect => sub {
|
90
|
0
|
0
|
|
0
|
|
0
|
print "RTM (re)connected.\n" if ($self->{options}->{debug});
|
91
|
0
|
|
|
|
|
0
|
});
|
92
|
|
|
|
|
|
|
$ws_client->on(error => sub {
|
93
|
0
|
|
|
0
|
|
0
|
my ($cli, $error) = @_;
|
94
|
0
|
|
|
|
|
0
|
print STDERR 'error: '. $error;
|
95
|
0
|
|
|
|
|
0
|
});
|
96
|
0
|
|
|
|
|
0
|
$ws_client->connect;
|
97
|
|
|
|
|
|
|
|
98
|
0
|
|
|
|
|
0
|
$self->{ws_client} = $ws_client;
|
99
|
0
|
|
|
|
|
0
|
$self->{socket} = $socket;
|
100
|
|
|
|
|
|
|
}
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub disconnect {
|
103
|
0
|
|
|
0
|
0
|
0
|
my $self = shift;
|
104
|
0
|
|
|
|
|
0
|
$self->{ws_client}->disconnect;
|
105
|
0
|
|
|
|
|
0
|
undef $self;
|
106
|
|
|
|
|
|
|
}
|
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub read {
|
109
|
0
|
|
|
0
|
0
|
0
|
my $self = shift;
|
110
|
0
|
|
|
|
|
0
|
my $data = '';
|
111
|
0
|
|
|
|
|
0
|
while (my $line = readline $self->{socket}) {
|
112
|
0
|
|
|
|
|
0
|
$data .= $line;
|
113
|
|
|
|
|
|
|
}
|
114
|
0
|
0
|
|
|
|
0
|
if ($data) {
|
115
|
0
|
|
|
|
|
0
|
$self->{ws_client}->read($data);
|
116
|
0
|
|
|
|
|
0
|
return $data =~ /.*hello.*/;
|
117
|
|
|
|
|
|
|
}
|
118
|
|
|
|
|
|
|
}
|
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub write {
|
121
|
0
|
|
|
0
|
0
|
0
|
my $self = shift;
|
122
|
0
|
|
|
|
|
0
|
$self->{ws_client}->write(JSON::encode_json({@_}));
|
123
|
|
|
|
|
|
|
}
|
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub find_conversation_id {
|
126
|
0
|
|
|
0
|
0
|
0
|
my $self = shift;
|
127
|
0
|
|
|
|
|
0
|
my ($name) = @_;
|
128
|
0
|
|
|
|
|
0
|
my $id = $self->{info}->_find_conversation_id($name);
|
129
|
0
|
0
|
0
|
|
|
0
|
$id ||= $self->_refetch_conversation_id($name) or die "There are no conversations of such name: $name";
|
130
|
0
|
|
|
|
|
0
|
return $id;
|
131
|
|
|
|
|
|
|
}
|
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub _refetch_conversation_id {
|
134
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
135
|
0
|
|
|
|
|
0
|
my ($name) = @_;
|
136
|
0
|
|
|
|
|
0
|
$self->_refetch_conversations;
|
137
|
0
|
|
|
|
|
0
|
return $self->{info}->_find_conversation_id($name);
|
138
|
|
|
|
|
|
|
}
|
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub find_conversation_name {
|
141
|
1
|
|
|
1
|
0
|
2
|
my $self = shift;
|
142
|
1
|
|
|
|
|
5
|
my ($id) = @_;
|
143
|
1
|
|
|
|
|
7
|
my $name = $self->{info}->_find_conversation_name($id);
|
144
|
1
|
50
|
33
|
|
|
5
|
$name ||= $self->_refetch_conversation_name($id) or warn "There are no conversations of such id: $id";
|
145
|
1
|
|
33
|
|
|
2
|
$name ||= $id;
|
146
|
1
|
|
|
|
|
3
|
return $name;
|
147
|
|
|
|
|
|
|
}
|
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub _refetch_conversation_name {
|
150
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
151
|
0
|
|
|
|
|
0
|
my ($id) = @_;
|
152
|
0
|
|
|
|
|
0
|
$self->_refetch_conversations;
|
153
|
0
|
|
|
|
|
0
|
return $self->{info}->_find_conversation_name($id);
|
154
|
|
|
|
|
|
|
}
|
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub _refetch_conversations {
|
157
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
158
|
0
|
|
|
|
|
0
|
my $res;
|
159
|
0
|
|
|
|
|
0
|
eval {
|
160
|
0
|
|
|
|
|
0
|
my $conversations = {};
|
161
|
0
|
|
|
|
|
0
|
my $cursor = "";
|
162
|
0
|
|
|
|
|
0
|
do {
|
163
|
0
|
|
|
|
|
0
|
$res = $ua->request(GET "https://slack.com/api/conversations.list?types=public_channel,private_channel&token=$self->{token}&cursor=$cursor&limit=1000");
|
164
|
0
|
|
|
|
|
0
|
my $args = JSON::from_json($res->content);
|
165
|
0
|
|
|
|
|
0
|
for my $conversation (@{$args->{channels}}) {
|
|
0
|
|
|
|
|
0
|
|
166
|
0
|
|
|
|
|
0
|
$conversations->{$conversation->{id}} = $conversation;
|
167
|
|
|
|
|
|
|
}
|
168
|
0
|
|
|
|
|
0
|
$cursor = $args->{response_metadata}->{next_cursor};
|
169
|
|
|
|
|
|
|
} until ($cursor eq "");
|
170
|
0
|
|
|
|
|
0
|
$self->{info}->{channels} = $conversations;
|
171
|
|
|
|
|
|
|
};
|
172
|
0
|
0
|
|
|
|
0
|
if ($@) {
|
173
|
0
|
|
|
|
|
0
|
die '_refetch_conversations response fail:'.Dumper $res->content;
|
174
|
|
|
|
|
|
|
}
|
175
|
|
|
|
|
|
|
}
|
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub find_user_name {
|
178
|
1
|
|
|
1
|
0
|
3
|
my $self = shift;
|
179
|
1
|
|
|
|
|
2
|
my ($id) = @_;
|
180
|
1
|
|
|
|
|
4
|
my $name = $self->{info}->_find_user_name($id);
|
181
|
1
|
50
|
33
|
|
|
4
|
$name ||= $self->_refetch_user_name($id) or warn "There are no users of such id: $id";
|
182
|
1
|
|
33
|
|
|
4
|
$name ||= $id;
|
183
|
1
|
|
|
|
|
2
|
return $name;
|
184
|
|
|
|
|
|
|
}
|
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub _refetch_user_id {
|
187
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
188
|
0
|
|
|
|
|
0
|
my ($name) = @_;
|
189
|
0
|
|
|
|
|
0
|
$self->_refetch_users;
|
190
|
0
|
|
|
|
|
0
|
return $self->{info}->_find_user_id($name);
|
191
|
|
|
|
|
|
|
}
|
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
sub _refetch_user_name {
|
194
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
195
|
0
|
|
|
|
|
0
|
my ($id) = @_;
|
196
|
0
|
|
|
|
|
0
|
$self->_refetch_users;
|
197
|
0
|
|
|
|
|
0
|
return $self->{info}->_find_user_name($id);
|
198
|
|
|
|
|
|
|
}
|
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub _refetch_users {
|
201
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
202
|
0
|
|
|
|
|
0
|
my $res;
|
203
|
0
|
|
|
|
|
0
|
eval {
|
204
|
0
|
|
|
|
|
0
|
my $users = {};
|
205
|
0
|
|
|
|
|
0
|
my $cursor = "";
|
206
|
0
|
|
|
|
|
0
|
do {
|
207
|
0
|
|
|
|
|
0
|
$res = $ua->request(GET "https://slack.com/api/users.list?token=$self->{token}&cursor=$cursor");
|
208
|
0
|
|
|
|
|
0
|
my $args = JSON::from_json($res->content);
|
209
|
0
|
|
|
|
|
0
|
for my $user (@{$args->{users}}) {
|
|
0
|
|
|
|
|
0
|
|
210
|
0
|
|
|
|
|
0
|
$users->{$user->{id}} = $user;
|
211
|
|
|
|
|
|
|
}
|
212
|
0
|
|
|
|
|
0
|
$cursor = $args->{response_metadata}->{next_cursor};
|
213
|
|
|
|
|
|
|
} until ($cursor eq "");
|
214
|
0
|
|
|
|
|
0
|
$self->{info}->{users} = $users;
|
215
|
|
|
|
|
|
|
};
|
216
|
0
|
0
|
|
|
|
0
|
if ($@) {
|
217
|
0
|
|
|
|
|
0
|
die '_refetch_users response fail:'.Dumper $res->content;
|
218
|
|
|
|
|
|
|
}
|
219
|
|
|
|
|
|
|
}
|
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub _listen {
|
222
|
5
|
|
|
5
|
|
2776
|
my $self = shift;
|
223
|
5
|
|
|
|
|
12
|
my ($buffer) = @_;
|
224
|
5
|
|
|
|
|
7
|
my $buffer_obj;
|
225
|
5
|
|
|
|
|
9
|
eval {
|
226
|
5
|
|
|
|
|
17
|
$buffer_obj = JSON::from_json($buffer);
|
227
|
|
|
|
|
|
|
};
|
228
|
5
|
50
|
|
|
|
104
|
if ($@) {
|
229
|
0
|
|
|
|
|
0
|
die "response is not json string. : $buffer";
|
230
|
|
|
|
|
|
|
}
|
231
|
5
|
50
|
33
|
|
|
33
|
if ($buffer_obj->{type} && $buffer_obj->{type} eq 'reconnect_url') {
|
232
|
0
|
|
|
|
|
0
|
$self->{info}->{url} = $buffer_obj->{url};
|
233
|
|
|
|
|
|
|
}
|
234
|
|
|
|
|
|
|
|
235
|
5
|
|
|
|
|
11
|
my ($user, $channel);
|
236
|
5
|
100
|
66
|
|
|
21
|
if ($buffer_obj->{user} && !ref($buffer_obj->{user})) {
|
237
|
1
|
|
|
|
|
5
|
$user = $self->find_user_name($buffer_obj->{user});
|
238
|
1
|
50
|
|
|
|
4
|
warn "There are no users of such id: $buffer_obj->{user}" unless $user;
|
239
|
|
|
|
|
|
|
}
|
240
|
5
|
100
|
100
|
|
|
30
|
if ($buffer_obj->{channel} && !ref($buffer_obj->{channel})) {
|
241
|
1
|
|
|
|
|
6
|
$channel = $self->find_conversation_name($buffer_obj->{channel});
|
242
|
1
|
50
|
|
|
|
3
|
warn "There are no conversations of such id: $buffer_obj->{channel}" unless $channel;
|
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
}
|
245
|
5
|
|
|
|
|
26
|
my $response = Slack::RTM::Bot::Response->new(
|
246
|
|
|
|
|
|
|
buffer => $buffer_obj,
|
247
|
|
|
|
|
|
|
user => $user,
|
248
|
|
|
|
|
|
|
channel => $channel
|
249
|
|
|
|
|
|
|
);
|
250
|
5
|
|
|
|
|
36
|
ACTION: for my $action(@{$self->{actions}}){
|
|
5
|
|
|
|
|
18
|
|
251
|
10
|
|
|
|
|
15
|
for my $key(keys %{$action->{events}}){
|
|
10
|
|
|
|
|
31
|
|
252
|
9
|
|
|
|
|
15
|
my $regex = $action->{events}->{$key};
|
253
|
9
|
100
|
100
|
|
|
64
|
if(!defined $response->{$key} || $response->{$key} !~ $regex){
|
254
|
5
|
|
|
|
|
24
|
next ACTION;
|
255
|
|
|
|
|
|
|
}
|
256
|
|
|
|
|
|
|
}
|
257
|
5
|
|
|
|
|
11
|
eval {
|
258
|
5
|
|
|
|
|
17
|
$action->{routine}->($response);
|
259
|
|
|
|
|
|
|
};
|
260
|
5
|
50
|
|
|
|
1461
|
if ($@) {
|
261
|
0
|
|
|
|
|
|
warn $@;
|
262
|
0
|
|
|
|
|
|
kill 9, @{$self->{pids}};
|
|
0
|
|
|
|
|
|
|
263
|
0
|
|
|
|
|
|
exit(1);
|
264
|
|
|
|
|
|
|
}
|
265
|
|
|
|
|
|
|
}
|
266
|
|
|
|
|
|
|
};
|
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
1;
|