1 package Xchat::VPIT::Clones;
6 use Scalar::Util qw<dualvar>;
10 use lib get_info 'xchatdir';
12 use Xchat::XPI::Events qw<delay>;
13 use Xchat::XPI::Utils qw<irc_lc save_context local_context>;
21 die 'Invalid PRE/POST' unless irc_lc(PRE . POST) eq PRE . POST;
23 our $VERSION = '0.04';
25 my ($ph, %users, %fetched);
26 my $extractor = PRE . '(.+?)' . POST;
27 $extractor = qr/$extractor/;
30 my ($host, $nick, $clones) = @_;
32 my @clones = $clones =~ /$extractor/go;
34 return "\002$nick\002 ($host) is a clone of : \002@clones\002\n";
38 my ($host, $nick, $clones) = @_;
40 my @clones = $clones =~ /$extractor/go;
42 return "\002$nick\002 ($host) has "
43 . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
44 . " left : \002@clones\002\n";
48 my ($host, $clones) = @_;
50 my @clones = $clones =~ /$extractor/go;
52 return "Clones ($host) : \002@clones\002\n";
56 my $userhost = lc $_[0];
58 return $userhost =~ /@([^@]+)$/ ? strip_code($1) : $userhost;
62 my ($nick, $host, $serv, $chan) = @_;
66 my $hosts = $users{$serv}{$chan};
67 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
69 my $clones = $hosts->{$host};
71 $nick = PRE . $nick . POST;
72 if (defined $clones) {
73 if (index(irc_lc($clones), irc_lc($nick)) < $[) {
74 $hosts->{$host} = dualvar int($clones) + 1, $clones . $nick;
77 $clones = dualvar 0, '';
78 $hosts->{$host} = dualvar 1, $nick;
85 my ($nick, $host, $serv, $chan) = @_;
90 my $hosts = $users{$serv}{$chan};
91 return 0 unless $hosts;
93 my $clones = $hosts->{$host};
94 return 0 unless $clones;
96 $nick = PRE . $nick . POST;
97 if ((my $off = index irc_lc($clones), $nick) >= $[) {
98 my $count = int $clones;
100 substr $clones, $off, length $nick, '';
101 return $hosts->{$host} = dualvar $count - 1, $clones;
103 delete $hosts->{$host};
110 my ($old, $new, $host, $serv, $chan) = @_;
113 $chan = irc_lc $chan;
115 my $hosts = $users{$serv}{$chan};
116 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
118 my $clones = $hosts->{$host};
120 $_ = PRE . $_ . POST for $old, $new;
121 if (defined $clones and (my $off = index irc_lc($clones), $old) >= $[) {
122 my $count = int $clones;
123 substr $clones, $off, length $old, '';
124 $hosts->{$host} = dualvar $count, $clones . $new;
126 $hosts->{$host} = dualvar 1, $new;
131 my ($serv, $chan) = @_;
133 $chan = irc_lc $chan;
135 return unless $fetched{$serv}{$chan};
136 my $hosts = $users{$serv}{$chan};
139 while (my ($host, $clones) = each %$hosts) {
142 print $ph clone_list_str $host, $clones;
150 my ($serv, $chan) = @_;
152 return 0 unless $serv and $chan;
154 $chan = irc_lc $chan;
155 return 0 unless $fetched{$serv}{$chan};
157 delete $users{$serv}{$chan};
158 delete $users{$serv} unless keys %{$users{$serv}};
160 delete $fetched{$serv}{$chan};
161 delete $fetched{$serv} unless keys %{$fetched{$serv}};
167 my ($serv, $chan) = @_;
170 for (get_list 'users') {
171 my $host = $_->{host};
172 next unless defined $host and length $host;
173 add $_->{nick}, host($host), $serv, $chan;
176 $fetched{$serv}{irc_lc($chan)} = 1 if $users;
181 hook_server '315', sub { # WHO end
182 my $serv = get_info 'server';
185 return EAT_NONE if $fetched{$serv}{irc_lc($chan)};
187 local_context $chan, $serv => sub {
195 # On join, the who finishes sometimes before the tab opens, so the scan result
196 # isn't always displayed in the proper context. Hence the delay()
198 hook_server 'JOIN', sub {
199 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
200 my $serv = get_info 'server';
201 my $chan = substr $_[0][2], 1; # starts with colon
203 my $clones = add $nick, host($userhost), $serv, $chan;
204 return EAT_NONE unless $clones > 0;
207 print $ph clone_enter_str $userhost, $nick, $clones;
211 local_context $chan, $serv, $printer or delay JOIN_DELAY, sub {
212 local_context $chan, $serv, $printer;
218 hook_server 'KICK', sub {
220 my $serv = get_info 'server';
223 if (nickcmp get_info('nick'), $nick) {
224 my $userinfo = user_info $nick;
225 my $userhost = $userinfo->{host};
226 if (defined $userhost and length $userhost) {
227 # If this isn't true, the kick happened before the first WHO response was
228 # received and the nick isn't in the database yet.
229 my $clones = remove $nick, host($userhost), $serv, $chan;
230 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
239 hook_server 'PART', sub {
240 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
241 my $serv = get_info 'server';
244 if (nickcmp get_info('nick'), $nick) {
245 my $clones = remove $nick, host($userhost), $serv, $chan;
246 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
254 hook_server 'QUIT', sub {
255 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
256 my $serv = get_info 'server';
257 my @chans = map [ $_->{channel}, $_->{context} ],
258 grep { $_->{type} == 2 and $_->{server} eq $serv }
261 if (nickcmp get_info('nick'), $nick) {
262 my $guard = save_context;
263 my $host = host $userhost;
265 my $clones = remove $nick, $host, $serv, $_->[0];
267 set_context $_->[1] or next;
268 print $ph clone_leave_str $userhost, $nick, $clones;
272 flush $serv, $_->[0] for @chans;
278 hook_print 'Disconnected', sub {
280 $servers{$_->{server}} = 1 for grep +($_->{flags} & 0b1011) == 0b1001,
283 delete @users{ grep !$servers{$_}, keys %users};
284 delete @fetched{grep !$servers{$_}, keys %fetched};
290 my ($old, $new) = @{$_[0]};
292 my $userinfo = user_info $new;
293 $userinfo = user_info $old unless defined $userinfo;
295 my $userhost = $userinfo->{host};
296 if (defined $userhost and length $userhost) {
297 # If the host isn't defined, the first WHO response hasn't been received yet,
298 # so the old nick isn't even in our database.
299 # Otherwise, the new nick would be added right now, and the old one would be
300 # when the WHO responses arrives (which may still refer to the old nick).
301 replace $old => $new, host($userhost),
302 get_info('server'), get_info('channel');
308 hook_print $_, \&nick_cb for 'Change Nick', 'Your Nick Changing';
310 hook_command 'CLSCAN', sub {
311 my $serv = get_info 'server';
312 my $chan = get_info 'channel';
314 if (!$fetched{$serv}{irc_lc($chan)} and !fetch($serv, $chan)) {
315 print $ph "Data still not available\n";
316 } elsif (!scan($serv, $chan)) {
317 print $ph "No clones found\n";
322 help_text => 'Scan for clones in the current channel'
325 $ph = Xchat::XPI->new(
326 name => 'Clones scanner',
328 desc => 'Automatic & on-demand clones scanner',
329 author => 'Vincent Pit (VPIT)',
330 email => 'perl@profvince.com',
331 url => 'http://www.profvince.com',