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<save_context local_context>;
21 our $VERSION = '0.04';
23 my ($ph, %users, %fetched);
24 my $extractor = PRE . '(.+?)' . POST;
25 $extractor = qr/$extractor/;
28 my ($host, $nick, $clones) = @_;
30 my @clones = $clones =~ /$extractor/go;
32 return "\002$nick\002 ($host) is a clone of : \002@clones\002\n";
36 my ($host, $nick, $clones) = @_;
38 my @clones = $clones =~ /$extractor/go;
40 return "\002$nick\002 ($host) has "
41 . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
42 . " left : \002@clones\002\n";
46 my ($host, $clones) = @_;
48 my @clones = $clones =~ /$extractor/go;
50 return "Clones ($host) : \002@clones\002\n";
54 my $userhost = lc $_[0];
56 return $userhost =~ /@([^@]+)$/ ? $1 : $userhost;
60 my ($nick, $host, $serv, $chan) = @_;
62 my $hosts = $users{$serv}{$chan};
63 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
65 my $clones = $hosts->{$host};
67 $nick = PRE . $nick . POST;
68 if (defined $clones) {
69 if (index($clones, $nick) < $[) {
70 $hosts->{$host} = dualvar int($clones) + 1, $clones . $nick;
73 $clones = dualvar 0, '';
74 $hosts->{$host} = dualvar 1, $nick;
81 my ($nick, $host, $serv, $chan) = @_;
83 my $hosts = $users{$serv}{$chan};
84 return 0 unless $hosts;
86 my $clones = $hosts->{$host};
87 return 0 unless $clones;
89 $nick = PRE . $nick . POST;
90 if ((my $off = index $clones, $nick) >= $[) {
91 my $count = int $clones;
93 substr $clones, $off, length $nick, '';
94 return $hosts->{$host} = dualvar $count - 1, $clones;
96 delete $hosts->{$host};
103 my ($old, $new, $host, $serv, $chan) = @_;
105 my $hosts = $users{$serv}{$chan};
106 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
108 my $clones = $hosts->{$host};
110 $_ = PRE . $_ . POST for $old, $new;
111 if (defined $clones and (my $off = index $clones, $old) >= $[) {
112 my $count = int $clones;
113 substr $clones, $off, length $old, '';
114 $hosts->{$host} = dualvar $count, $clones . $new;
116 $hosts->{$host} = dualvar 1, $new;
121 my ($serv, $chan) = @_;
123 return unless $fetched{$serv}{$chan};
124 my $hosts = $users{$serv}{$chan};
127 while (my ($host, $clones) = each %$hosts) {
130 print $ph clone_list_str $host, $clones;
138 my ($serv, $chan) = @_;
140 return 0 unless $serv and $chan and $fetched{$serv}{$chan};
142 delete $users{$serv}{$chan};
143 delete $users{$serv} unless keys %{$users{$serv}};
145 delete $fetched{$serv}{$chan};
146 delete $fetched{$serv} unless keys %{$fetched{$serv}};
152 my ($serv, $chan) = @_;
155 for (get_list 'users') {
156 my $host = $_->{host};
157 next unless defined $host and length $host;
158 add $_->{nick}, host($host), $serv, $chan;
161 $fetched{$serv}{$chan} = 1 if $users;
166 hook_server '315', sub { # WHO end
167 my $serv = get_info 'server';
168 my $chan = lc $_[0][3];
170 return EAT_NONE if $fetched{$serv}{$chan};
172 local_context $chan, $serv => sub {
180 # On join, the who finishes sometimes before the tab opens, so the scan result
181 # isn't always displayed in the proper context. Hence the delay()
183 hook_server 'JOIN', sub {
184 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
185 my $serv = get_info 'server';
186 my $chan = lc substr $_[0][2], 1; # starts with colon
188 my $clones = add $nick, host($userhost), $serv, $chan;
189 return EAT_NONE unless $clones > 0;
191 local_context $chan, $serv => sub {
192 print $ph clone_enter_str $userhost, $nick, $clones;
195 delay JOIN_DELAY, sub {
196 local_context $chan, $serv => sub {
197 print $ph clone_enter_str $userhost, $nick, $clones;
205 hook_server 'KICK', sub {
207 my $serv = get_info 'server';
208 my $chan = lc $_[0][2];
210 if (nickcmp get_info('nick'), $nick) {
211 my $userinfo = user_info $nick;
212 my $userhost = $userinfo->{host};
213 if (defined $userhost and length $userhost) {
214 # If this isn't true, the kick happened before the first WHO response was
215 # received and the nick isn't in the database yet.
216 my $clones = remove $nick, host($userhost), $serv, $chan;
217 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
226 hook_server 'PART', sub {
227 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
228 my $serv = get_info 'server';
229 my $chan = lc $_[0][2];
231 if (nickcmp get_info('nick'), $nick) {
232 my $clones = remove $nick, host($userhost), $serv, $chan;
233 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
241 hook_server 'QUIT', sub {
242 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
243 my $serv = get_info 'server';
244 my @chans = map [ lc $_->{channel}, $_->{context} ],
245 grep { $_->{type} == 2 and $_->{server} eq $serv }
248 if (nickcmp get_info('nick'), $nick) {
249 my $guard = save_context;
250 my $host = host $userhost;
252 my $clones = remove $nick, $host, $serv, $_->[0];
254 set_context $_->[1] or next;
255 print $ph clone_leave_str $userhost, $nick, $clones;
259 flush $serv, $_->[0] for @chans;
265 hook_print 'Disconnected', sub {
267 $servers{$_->{server}} = 1 for grep +($_->{flags} & 0b1011) == 0b1001,
270 delete @users{ grep !$servers{$_}, keys %users};
271 delete @fetched{grep !$servers{$_}, keys %fetched};
277 my ($old, $new) = @{$_[0]};
279 my $userinfo = user_info $new;
280 $userinfo = user_info $old unless defined $userinfo;
282 my $userhost = $userinfo->{host};
283 if (defined $userhost and length $userhost) {
284 # If the host isn't defined, the first WHO response hasn't been received yet,
285 # so the old nick isn't even in our database.
286 # Otherwise, the new nick would be added right now, and the old one would be
287 # when the WHO responses arrives (which may still refer to the old nick).
288 replace $old => $new, host($userhost),
289 get_info('server'), lc get_info('channel');
295 hook_print $_, \&nick_cb for 'Change Nick', 'Your Nick Changing';
297 hook_command 'CLSCAN', sub {
298 my $serv = get_info 'server';
299 my $chan = lc get_info 'channel';
301 if (!$fetched{$serv}{$chan} and !fetch($serv, $chan)) {
302 print $ph "Data still not available\n";
303 } elsif (!scan($serv, $chan)) {
304 print $ph "No clones found\n";
309 help_text => 'Scan for clones in the current channel'
312 $ph = Xchat::XPI->new(
313 name => 'Clones scanner',
315 desc => 'Automatic & on-demand clones scanner',
316 author => 'Vincent Pit (VPIT)',
317 email => 'perl@profvince.com',
318 url => 'http://www.profvince.com',
319 unload => sub { undef %users },