line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package IkuSan; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
778
|
use 5.10.0; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
55
|
|
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
36
|
|
6
|
1
|
|
|
1
|
|
6
|
use warnings; |
|
1
|
|
|
|
|
11
|
|
|
1
|
|
|
|
|
53
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = "0.01"; |
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
859
|
use AnySan; |
|
1
|
|
|
|
|
20517
|
|
|
1
|
|
|
|
|
35
|
|
11
|
1
|
|
|
1
|
|
1136
|
use AnySan::Provider::IRC; |
|
1
|
|
|
|
|
109503
|
|
|
1
|
|
|
|
|
64
|
|
12
|
1
|
|
|
1
|
|
13
|
use Encode; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
70
|
|
13
|
1
|
|
|
1
|
|
1110
|
use Plack::Request; |
|
1
|
|
|
|
|
79044
|
|
|
1
|
|
|
|
|
31
|
|
14
|
1
|
|
|
1
|
|
1042
|
use Twiggy::Server; |
|
1
|
|
|
|
|
25374
|
|
|
1
|
|
|
|
|
41
|
|
15
|
1
|
|
|
|
|
7
|
use Getopt::Long qw( |
16
|
|
|
|
|
|
|
GetOptionsFromString |
17
|
|
|
|
|
|
|
:config posix_default no_ignore_case bundling |
18
|
1
|
|
|
1
|
|
1492
|
); |
|
1
|
|
|
|
|
13756
|
|
19
|
1
|
|
|
1
|
|
1367
|
use AnyEvent::ForkManager; |
|
1
|
|
|
|
|
12319
|
|
|
1
|
|
|
|
|
45
|
|
20
|
1
|
|
|
1
|
|
9
|
use Try::Tiny; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2044
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub new { |
23
|
0
|
|
|
0
|
0
|
|
my $class = shift; |
24
|
0
|
0
|
|
|
|
|
my %args = @_ == 1 ? %{$_[0]} : @_; |
|
0
|
|
|
|
|
|
|
25
|
0
|
|
|
|
|
|
my $self = bless \%args, $class; |
26
|
|
|
|
|
|
|
|
27
|
0
|
|
0
|
|
|
|
$self->{nickname} //= 'ikusan'; |
28
|
0
|
|
0
|
|
|
|
$self->{port} ||= 6667; |
29
|
0
|
|
0
|
|
|
|
$self->{post_interval} //= 2; |
30
|
0
|
|
0
|
|
|
|
$self->{reconnect_interval} //= 3; |
31
|
0
|
|
0
|
|
|
|
$self->{receive_commands} //= ['PRIVMSG']; |
32
|
0
|
|
|
|
|
|
$self->{http_host} = '127.0.0.1'; # 固定 |
33
|
0
|
|
0
|
|
|
|
$self->{http_port} //= 19300; |
34
|
0
|
|
0
|
|
|
|
$self->{max_workers} //= 10; |
35
|
0
|
|
|
|
|
|
$self->{pid} = $$; # 固定 |
36
|
|
|
|
|
|
|
$self->{on_option_error} //= sub { |
37
|
0
|
|
|
0
|
|
|
my ($e, $receive) = @_; |
38
|
0
|
|
|
|
|
|
warn "on_option_error: $e"; |
39
|
0
|
|
0
|
|
|
|
}; |
40
|
|
|
|
|
|
|
$self->{on_start} //= sub { |
41
|
0
|
|
|
0
|
|
|
my ($pm, $receive, $sub, $message, @matches) = @_; |
42
|
0
|
|
|
|
|
|
warn "on_start: $message"; |
43
|
0
|
|
0
|
|
|
|
}; |
44
|
|
|
|
|
|
|
$self->{on_error} //= sub { |
45
|
0
|
|
|
0
|
|
|
my ($e, $pm, $receive, $sub, $message, @matches) = @_; |
46
|
0
|
|
|
|
|
|
warn "on_error: $e"; |
47
|
0
|
|
0
|
|
|
|
}; |
48
|
|
|
|
|
|
|
$self->{on_finish} //= sub { |
49
|
0
|
|
|
0
|
|
|
my ($pm, $receive, $sub, $message, @matches) = @_; |
50
|
0
|
|
|
|
|
|
warn "on_finish: $message"; |
51
|
0
|
|
0
|
|
|
|
}; |
52
|
|
|
|
|
|
|
|
53
|
0
|
|
|
|
|
|
my ($irc, $is_connect, $connector); |
54
|
|
|
|
|
|
|
$connector = sub { |
55
|
|
|
|
|
|
|
irc |
56
|
|
|
|
|
|
|
$self->{host}, |
57
|
|
|
|
|
|
|
port => $self->{port}, |
58
|
|
|
|
|
|
|
key => $self->{keyword}, |
59
|
|
|
|
|
|
|
password => $self->{password}, |
60
|
|
|
|
|
|
|
nickname => $self->{nickname}, |
61
|
|
|
|
|
|
|
user => $self->{user}, |
62
|
|
|
|
|
|
|
interval => $self->{post_interval}, |
63
|
|
|
|
|
|
|
enable_ssl => $self->{enable_ssl}, |
64
|
|
|
|
|
|
|
recive_commands => $self->{receive_commands}, |
65
|
|
|
|
|
|
|
on_connect => sub { |
66
|
0
|
|
|
|
|
|
my ($con, $err) = @_; |
67
|
0
|
0
|
|
|
|
|
if (defined $err) { |
68
|
0
|
|
|
|
|
|
warn "connect error: $err\n"; |
69
|
0
|
0
|
|
|
|
|
exit 1 unless $self->{reconnect_interval}; |
70
|
0
|
|
|
|
|
|
sleep $self->{reconnect_interval}; |
71
|
0
|
|
|
|
|
|
$con->disconnect('try reconnect'); |
72
|
|
|
|
|
|
|
} else { |
73
|
0
|
|
|
|
|
|
warn 'connect'; |
74
|
0
|
|
|
|
|
|
$is_connect = 1; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
}, |
77
|
|
|
|
|
|
|
on_disconnect => sub { |
78
|
0
|
|
|
|
|
|
warn 'disconnect'; |
79
|
|
|
|
|
|
|
# XXX: bad hack... |
80
|
0
|
|
|
|
|
|
undef $irc->{client}; |
81
|
0
|
|
|
|
|
|
undef $irc->{SEND_TIMER}; |
82
|
0
|
|
|
|
|
|
undef $irc; |
83
|
0
|
|
|
|
|
|
$is_connect = 0; |
84
|
0
|
|
|
|
|
|
$irc = $connector->(); |
85
|
|
|
|
|
|
|
}, |
86
|
0
|
|
|
|
|
|
channels => { |
87
|
0
|
0
|
|
0
|
|
|
map { my $chan = $_; $chan = '#'.$chan unless $chan =~ /^#/; ;($chan => +{}) } @{ $self->{join_channels} || [] }, |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
}; |
89
|
0
|
|
|
|
|
|
}; |
90
|
0
|
|
|
|
|
|
$irc = $connector->(); |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
my $app = sub { |
93
|
0
|
|
|
0
|
|
|
my $req = Plack::Request->new(shift); |
94
|
0
|
0
|
0
|
|
|
|
if ($req->address eq $self->{http_host} && $req->method eq 'POST') { |
95
|
0
|
|
|
|
|
|
my $message = $req->param('message'); |
96
|
0
|
|
|
|
|
|
my $channel = $req->param('channel'); |
97
|
0
|
|
|
|
|
|
my $privmsg = $req->param('privmsg'); |
98
|
0
|
|
|
|
|
|
my @message = split(/\n/, $message); |
99
|
0
|
|
|
|
|
|
$irc->send_message( $message[0], channel => $channel, privmsg => $privmsg ); |
100
|
0
|
|
|
|
|
|
return [ 200, ["Content-Type" => "text/plain"], ["message sent channel: $channel $message"] ] |
101
|
|
|
|
|
|
|
} |
102
|
0
|
|
|
|
|
|
[ 404, ["Content-Type" => "text/plain"], ["not found"] ] |
103
|
0
|
|
|
|
|
|
}; |
104
|
|
|
|
|
|
|
|
105
|
0
|
|
|
|
|
|
warn sprintf("starting httpd: http://%s:%s", $self->{http_host}, $self->{http_port}); |
106
|
0
|
|
|
|
|
|
my $twiggy = Twiggy::Server->new( |
107
|
|
|
|
|
|
|
host => $self->{http_host}, |
108
|
|
|
|
|
|
|
port => $self->{http_port}, |
109
|
|
|
|
|
|
|
); |
110
|
|
|
|
|
|
|
|
111
|
0
|
|
|
|
|
|
$twiggy->register_service($app); |
112
|
|
|
|
|
|
|
|
113
|
0
|
|
|
|
|
|
my $pm = AnyEvent::ForkManager->new( |
114
|
|
|
|
|
|
|
max_workers => $self->{max_workers}, |
115
|
|
|
|
|
|
|
); |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
AnySan->register_listener( |
118
|
|
|
|
|
|
|
$self->{nickname} => { |
119
|
|
|
|
|
|
|
cb => sub { |
120
|
0
|
|
|
0
|
|
|
my $receive = shift; |
121
|
0
|
|
|
|
|
|
$receive->{message} = decode_utf8 $receive->{message}; |
122
|
0
|
|
|
|
|
|
$receive->{http_host} = $self->{http_host}; |
123
|
0
|
|
|
|
|
|
$receive->{http_port} = $self->{http_port}; |
124
|
0
|
|
|
|
|
|
$receive->{pid} = $self->{pid}; |
125
|
0
|
|
|
|
|
|
my $respond = []; |
126
|
|
|
|
|
|
|
try { |
127
|
0
|
|
|
|
|
|
$respond = $self->_respond($receive); |
128
|
|
|
|
|
|
|
} catch { |
129
|
0
|
|
|
|
|
|
$self->{on_option_error}->($_, $receive); |
130
|
0
|
|
|
|
|
|
}; |
131
|
0
|
|
|
|
|
|
for my $r (@$respond) { |
132
|
0
|
|
|
|
|
|
my ($sub, $message, @matches) = @$r; |
133
|
|
|
|
|
|
|
$pm->start( |
134
|
|
|
|
|
|
|
cb => sub { |
135
|
0
|
|
|
|
|
|
my ($pm, $receive, $sub, $message, @matches) = @_; |
136
|
0
|
|
|
|
|
|
$self->{on_start}->($pm, $receive, $sub, $message, @matches); |
137
|
|
|
|
|
|
|
try { |
138
|
0
|
|
|
|
|
|
$sub->($pm, $receive, $sub, $message, @matches); |
139
|
|
|
|
|
|
|
} catch { |
140
|
0
|
|
|
|
|
|
$self->{on_error}->($_, $pm, $receive, $sub, $message, @matches); |
141
|
|
|
|
|
|
|
} finally { |
142
|
0
|
0
|
|
|
|
|
$self->{on_finish}->($pm, $receive, $sub, $message, @matches) unless (@_); |
143
|
0
|
|
|
|
|
|
}; |
144
|
|
|
|
|
|
|
}, |
145
|
0
|
|
|
|
|
|
args => [$receive, $sub, $message, @matches], |
146
|
|
|
|
|
|
|
); |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
} |
150
|
0
|
|
|
|
|
|
); |
151
|
|
|
|
|
|
|
|
152
|
0
|
|
|
|
|
|
$self; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub on_message { |
156
|
0
|
|
|
0
|
0
|
|
my ($self, @jobs) = @_; |
157
|
0
|
|
|
|
|
|
while (my ($reg, $sub) = splice @jobs, 0, 2) { |
158
|
0
|
|
|
|
|
|
push @{ $self->_reactions }, [$reg, $sub]; |
|
0
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub on_command { |
163
|
0
|
|
|
0
|
0
|
|
my ($self, @jobs) = @_; |
164
|
0
|
|
|
|
|
|
while (my ($command, $sub) = splice @jobs, 0, 2) { |
165
|
0
|
|
|
|
|
|
my $reg = _build_command_reg($self->{nickname}, $command); |
166
|
0
|
|
|
|
|
|
push @{ $self->_reactions }, [$reg, $sub, $command]; |
|
0
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub on_option { |
171
|
0
|
|
|
0
|
0
|
|
my ($self, @jobs) = @_; |
172
|
0
|
|
|
|
|
|
while (my ($command, $option, $sub) = splice @jobs, 0, 3) { |
173
|
0
|
0
|
|
|
|
|
die "on_option is require 3 arguments." unless $sub; |
174
|
0
|
|
|
|
|
|
my $reg = _build_command_reg($self->{nickname}, $command); |
175
|
0
|
|
|
|
|
|
push @{ $self->_reactions }, [$reg, $sub, $command, $option]; |
|
0
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub _build_command_reg { |
180
|
0
|
|
|
0
|
|
|
my ($nick, $command) = @_; |
181
|
|
|
|
|
|
|
|
182
|
0
|
|
|
|
|
|
my $prefix = '^\s*'.quotemeta($nick). '_*[:\s]\s*' . quotemeta($command); |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
0
|
|
|
0
|
0
|
|
sub fever { AnySan->run } |
186
|
|
|
|
|
|
|
|
187
|
0
|
|
|
0
|
0
|
|
sub respond_all { shift->{respond_all} } |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub _reactions { |
190
|
0
|
|
0
|
0
|
|
|
shift->{_reactions} ||= []; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
sub _respond { |
194
|
0
|
|
|
0
|
|
|
my ($self, $receive) = @_; |
195
|
|
|
|
|
|
|
|
196
|
0
|
|
|
|
|
|
my @result = (); |
197
|
0
|
|
|
|
|
|
my $message = $receive->message; |
198
|
0
|
|
|
|
|
|
$message =~ s/^\s+//; $message =~ s/\s+$//; |
|
0
|
|
|
|
|
|
|
199
|
0
|
|
|
|
|
|
for my $reaction (@{ $self->_reactions }) { |
|
0
|
|
|
|
|
|
|
200
|
0
|
|
|
|
|
|
my ($reg, $sub, $command, $option) = @$reaction; |
201
|
0
|
0
|
|
|
|
|
if (my @matches = $message =~ $reg) { |
202
|
0
|
0
|
|
|
|
|
if (defined $option) { |
|
|
0
|
|
|
|
|
|
203
|
0
|
|
|
|
|
|
@matches = _build_option_args($reg, $message, $option); |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
elsif (defined $command) { |
206
|
0
|
|
|
|
|
|
@matches = _build_command_args($reg, $message); |
207
|
|
|
|
|
|
|
} |
208
|
0
|
|
|
|
|
|
push @result, [$sub, $message, @matches]; |
209
|
0
|
0
|
|
|
|
|
return \@result unless $self->respond_all; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
0
|
|
|
|
|
|
return \@result; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub _build_command_args { |
217
|
0
|
|
|
0
|
|
|
my ($reg, $mes) = @_; |
218
|
0
|
|
|
|
|
|
$mes =~ s/$reg//; |
219
|
0
|
|
|
|
|
|
$mes =~ s/^\s+//; $mes =~ s/\s+$//; |
|
0
|
|
|
|
|
|
|
220
|
0
|
|
|
|
|
|
split /\s+/, $mes; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
sub _build_option_args { |
224
|
0
|
|
|
0
|
|
|
my ($reg, $mes, $opt) = @_; |
225
|
0
|
|
|
|
|
|
$mes =~ s/$reg//; |
226
|
0
|
|
|
|
|
|
$mes =~ s/^\s+//; $mes =~ s/\s+$//; |
|
0
|
|
|
|
|
|
|
227
|
0
|
|
|
|
|
|
my $warn = ""; |
228
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
229
|
0
|
|
|
0
|
|
|
$warn = $_[0]; chomp($warn) |
|
0
|
|
|
|
|
|
|
230
|
0
|
|
|
|
|
|
}; |
231
|
0
|
|
|
|
|
|
GetOptionsFromString($mes, \my %opts, @$opt); |
232
|
0
|
0
|
|
|
|
|
die $warn if ($warn); |
233
|
0
|
|
|
|
|
|
return %opts; |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
1; |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
package # hide from pause |
239
|
|
|
|
|
|
|
AnySan::Receive; |
240
|
|
|
|
|
|
|
|
241
|
1
|
|
|
1
|
|
1138
|
use Furl; |
|
1
|
|
|
|
|
18601
|
|
|
1
|
|
|
|
|
32
|
|
242
|
1
|
|
|
1
|
|
10
|
use Encode qw/encode_utf8/; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
357
|
|
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
sub furl { |
245
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
246
|
0
|
|
|
|
|
|
$self->{_furl} = Furl->new(); |
247
|
0
|
|
|
|
|
|
$self->{_furl}; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub notice { |
251
|
0
|
|
|
0
|
0
|
|
my ($self, $msg) = @_; |
252
|
0
|
|
|
|
|
|
$self->reply($msg) |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub privmsg { |
256
|
0
|
|
|
0
|
0
|
|
my ($self, $msg) = @_; |
257
|
0
|
|
|
|
|
|
$self->reply($msg, privmsg => 1) |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub reply { |
261
|
0
|
|
|
0
|
0
|
|
my ($self, $msg, %args) = @_; |
262
|
0
|
|
|
|
|
|
my @msg = split(/\n/, $msg); |
263
|
0
|
0
|
|
|
|
|
if ($self->{pid} == $$) { |
264
|
0
|
0
|
|
|
|
|
$self->attribute('send_command', 'PRIVMSG') if ($args{privmsg}); |
265
|
0
|
|
|
|
|
|
$self->send_reply($msg[0]); |
266
|
|
|
|
|
|
|
} else { |
267
|
0
|
|
0
|
|
|
|
$self->furl->post( |
268
|
|
|
|
|
|
|
sprintf("http://%s:%s", $self->{http_host}, $self->{http_port}), [], [ |
269
|
|
|
|
|
|
|
message => encode_utf8 $msg, |
270
|
|
|
|
|
|
|
channel => $self->attribute("channel"), |
271
|
|
|
|
|
|
|
privmsg => $args{privmsg} || 0, |
272
|
|
|
|
|
|
|
], |
273
|
|
|
|
|
|
|
); |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
1; |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
__END__ |