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