1 package Xchat::VPIT::Clones;
6 use Scalar::Util qw<dualvar>;
10 use lib get_info 'xchatdir';
12 use Xchat::XPI::Events qw<delay>;
20 our $VERSION = '0.04';
22 my ($ph, %users, %fetched);
23 my $extractor = PRE . '(.+?)' . POST;
24 $extractor = qr/$extractor/;
27 my ($host, $nick, $clones) = @_;
28 my @clones = $clones =~ /$extractor/g;
29 return "\002$nick\002 ($host) is a clone of : \002@clones\002\n";
33 my ($host, $nick, $clones) = @_;
34 my @clones = $clones =~ /$extractor/g;
35 return "\002$nick\002 ($host) has "
36 . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
37 . " left : \002@clones\002\n";
41 my ($host, $clones) = @_;
42 my @clones = $clones =~ /$extractor/g;
43 return "Clones ($host) : \002@clones\002\n";
47 my $userhost = lc $_[0];
48 return $userhost =~ /@([^@]+)$/ ? $1 : $userhost;
52 my ($nick, $host, $serv, $chan) = @_;
53 my $hosts = $users{$serv}{$chan};
54 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
55 my $clones = $hosts->{$host};
56 $nick = PRE . $nick . POST;
57 if (defined $clones) {
58 if (index($clones, $nick) < $[) {
59 $hosts->{$host} = dualvar int($clones) + 1, $clones . $nick;
62 $clones = dualvar 0, '';
63 $hosts->{$host} = dualvar 1, $nick;
69 my ($nick, $host, $serv, $chan) = @_;
70 my $hosts = $users{$serv}{$chan};
71 return 0 unless $hosts;
72 my $clones = $hosts->{$host};
73 return 0 unless $clones;
74 $nick = PRE . $nick . POST;
75 if ((my $off = index $clones, $nick) >= $[) {
76 my $count = int $clones;
78 substr $clones, $off, length $nick, '';
79 return $hosts->{$host} = dualvar $count - 1,
82 delete $hosts->{$host};
89 my ($old, $new, $host, $serv, $chan) = @_;
90 my $hosts = $users{$serv}{$chan};
91 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
92 my $clones = $hosts->{$host};
93 ($old, $new) = map { PRE . $_ . POST } $old, $new;
94 if (defined $clones && (my $off = index $clones, $old) >= $[) {
95 my $count = int $clones;
96 substr $clones, $off, length $old, '';
97 $hosts->{$host} = dualvar $count, $clones . $new;
99 $hosts->{$host} = dualvar 1, $new;
104 my ($serv, $chan) = @_;
105 return unless $fetched{$serv}{$chan};
106 my $hosts = $users{$serv}{$chan};
108 while (my ($host, $clones) = each %$hosts) {
111 print $ph clone_list_str $host, $clones;
118 my ($serv, $chan) = @_;
119 return 0 unless $serv && $chan && $fetched{$serv}{$chan};
120 delete $users{$serv}{$chan};
121 delete $users{$serv} unless keys %{$users{$serv}};
122 delete $fetched{$serv}{$chan};
123 delete $fetched{$serv} unless keys %{$fetched{$serv}};
128 my ($serv, $chan) = @_;
129 my @users = grep { defined $_->{host} and length $_->{host} }
132 add $_->{nick}, host($_->{host}), $serv, $chan for @users;
133 $fetched{$serv}{$chan} = 1;
135 return scalar @users;
138 hook_server '315', sub { # WHO end
139 my $serv = get_info 'server';
140 my $chan = lc $_[0][3];
141 return EAT_NONE if $fetched{$serv}{$chan};
142 my $oldctxt = get_context;
143 set_context $chan, $serv or return EAT_NONE;
146 set_context $oldctxt;
150 # On join, the who finishes sometimes before the tab opens, so the scan result
151 # isn't always displayed in the proper context. Hence the delay()
153 hook_server 'JOIN', sub {
154 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
155 my $serv = get_info 'server';
156 my $chan = lc substr $_[0][2], 1; # starts with colon
157 my $clones = add $nick, host($userhost), $serv, $chan;
159 my $oldctxt = get_context;
160 if (set_context $chan, $serv) {
161 print $ph clone_enter_str $userhost, $nick, $clones;
162 set_context $oldctxt;
164 delay JOIN_DELAY, sub {
165 my $oldctxt = get_context;
166 return unless set_context $chan, $serv;
167 print $ph clone_enter_str $userhost, $nick, $clones;
168 set_context $oldctxt;
175 hook_server 'KICK', sub {
177 my $serv = get_info 'server';
178 my $chan = lc $_[0][2];
179 if (nickcmp get_info('nick'), $nick) {
180 my $userinfo = user_info $nick;
181 my $userhost = $userinfo->{host};
182 if (defined $userhost and length $userhost) {
183 # If this isn't true, the kick happened before the first WHO response was
184 # received and the nick isn't in the database yet.
185 my $clones = remove $nick, host($userhost), $serv, $chan;
186 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
194 hook_server 'PART', sub {
195 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
196 my $serv = get_info 'server';
197 my $chan = lc $_[0][2];
198 if (nickcmp get_info('nick'), $nick) {
199 my $clones = remove $nick, host($userhost), $serv, $chan;
200 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
207 hook_server 'QUIT', sub {
208 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
209 my $serv = get_info 'server';
210 my @chans = map { [ lc $_->{channel}, $_->{context} ] }
211 grep { $_->{type} eq 2 && $_->{server} eq $serv }
213 if (nickcmp get_info('nick'), $nick) {
214 my $oldctxt = get_context;
215 my $host = host $userhost;
217 my $clones = remove $nick, $host, $serv, $_->[0];
219 set_context $_->[1] or next;
220 print $ph clone_leave_str $userhost, $nick, $clones;
223 set_context $oldctxt;
225 flush $serv, $_->[0] for @chans;
230 hook_print 'Disconnected', sub {
231 my %servers = map { $_->{server} => 1 }
232 grep { $_->{flags} & 9 && not $_->{flags} & 2 }
234 delete $users{$_} for grep { !$servers{$_} } keys %users;
235 delete $fetched{$_} for grep { !$servers{$_} } keys %fetched;
240 my ($old, $new) = @{$_[0]};
241 my $userinfo = user_info $new;
242 $userinfo = user_info $old unless defined $userinfo;
243 my $userhost = $userinfo->{host};
244 if (defined $userhost and length $userhost) {
245 # If the host isn't defined, the first WHO response hasn't been received yet,
246 # so the old nick isn't even in our database.
247 # Otherwise, the new nick would be added right now, and the old one would be
248 # when the WHO responses arrives (which may still refer to the old nick).
249 replace $old => $new, host($userhost),
250 get_info('server'), lc get_info('channel');
255 hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');
257 hook_command 'CLSCAN', sub {
258 my $serv = get_info 'server';
259 my $chan = lc get_info 'channel';
260 if (!$fetched{$serv}{$chan} && !fetch($serv, $chan)) {
261 print $ph "Data still not available\n";
262 } elsif (!scan($serv, $chan)) {
263 print $ph "No clones found\n";
267 help_text => 'Scan for clones in the current channel'
270 $ph = Xchat::XPI->new(
271 name => 'Clones scanner',
273 desc => 'Automatic & on-demand clones scanner',
274 author => 'Vincent Pit (VPIT)',
275 email => 'perl@profvince.com',
276 url => 'http://www.profvince.com',
277 unload => sub { undef %users },