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 my ($host) = $userhost =~ /@([^@]+)$/;
49 return $host || $userhost;
53 my ($nick, $host, $serv, $chan) = @_;
54 my $hosts = $users{$serv}{$chan};
55 $users{$serv}{$chan} = $hosts = { } if not defined $hosts;
56 my $clones = $hosts->{$host};
57 $nick = PRE . $nick . POST;
58 if (defined $clones) {
59 if ((index $clones, $nick) < $[) {
60 $hosts->{$host} = dualvar int($clones) + 1, $clones . $nick;
63 $clones = dualvar 0, '';
64 $hosts->{$host} = dualvar 1, $nick;
70 my ($nick, $host, $serv, $chan) = @_;
71 my $hosts = $users{$serv}{$chan};
72 return 0 unless $hosts;
73 my $clones = $hosts->{$host};
74 return 0 unless $clones;
75 $nick = PRE . $nick . POST;
76 if ((my $off = index $clones, $nick) >= $[) {
77 my $count = int $clones;
79 substr $clones, $off, length $nick, '';
80 return $hosts->{$host} = dualvar $count - 1,
83 delete $hosts->{$host};
90 my ($old, $new, $host, $serv, $chan) = @_;
91 my $hosts = $users{$serv}{$chan};
92 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
93 my $clones = $hosts->{$host};
94 ($old, $new) = map { PRE . $_ . POST } $old, $new;
95 if (defined $clones && (my $off = index $clones, $old) >= $[) {
96 my $count = int $clones;
97 substr $clones, $off, length $old, '';
98 $hosts->{$host} = dualvar $count, $clones . $new;
100 $hosts->{$host} = dualvar 1, $new;
105 my ($serv, $chan) = @_;
106 return unless $fetched{$serv}{$chan};
107 my $hosts = $users{$serv}{$chan};
109 while (my ($host, $clones) = each %$hosts) {
112 print $ph clone_list_str $host, $clones;
119 my ($serv, $chan) = @_;
120 return 0 unless $serv && $chan && $fetched{$serv}{$chan};
121 delete $users{$serv}{$chan};
122 delete $users{$serv} unless keys %{$users{$serv}};
123 delete $fetched{$serv}{$chan};
124 delete $fetched{$serv} unless keys %{$fetched{$serv}};
129 my ($serv, $chan) = @_;
130 my @users = grep { defined $_->{host} and length $_->{host} }
133 add $_->{nick}, host($_->{host}), $serv, $chan for @users;
134 $fetched{$serv}{$chan} = 1;
136 return scalar @users;
139 hook_server '315', sub { # WHO end
140 my $serv = get_info 'server';
141 my $chan = lc $_[0][3];
142 return EAT_NONE if $fetched{$serv}{$chan};
143 my $oldctxt = get_context;
144 set_context $chan, $serv or return EAT_NONE;
147 set_context $oldctxt;
151 # On join, the who finishes sometimes before the tab opens, so the scan result
152 # isn't always displayed in the proper context. Hence the delay()
154 hook_server 'JOIN', sub {
155 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
156 my $serv = get_info 'server';
157 my $chan = lc substr $_[0][2], 1; # starts with colon
158 my $clones = add $nick, host($userhost), $serv, $chan;
160 my $oldctxt = get_context;
161 if (set_context $chan, $serv) {
162 print $ph clone_enter_str $userhost, $nick, $clones;
163 set_context $oldctxt;
165 delay JOIN_DELAY, sub {
166 my $oldctxt = get_context;
167 return unless set_context $chan, $serv;
168 print $ph clone_enter_str $userhost, $nick, $clones;
169 set_context $oldctxt;
176 hook_server 'KICK', sub {
178 my $serv = get_info 'server';
179 my $chan = lc $_[0][2];
180 if (nickcmp get_info('nick'), $nick) {
181 my $userinfo = user_info $nick;
182 return EAT_NONE unless $userinfo;
183 my $userhost = $userinfo->{host};
184 my $clones = remove $nick, host($userhost), $serv, $chan;
185 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
192 hook_server 'PART', sub {
193 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
194 my $serv = get_info 'server';
195 my $chan = lc $_[0][2];
196 if (nickcmp get_info('nick'), $nick) {
197 my $clones = remove $nick, host($userhost), $serv, $chan;
198 print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
205 hook_server 'QUIT', sub {
206 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
207 my $serv = get_info 'server';
208 my @chans = map { [ lc $_->{channel}, $_->{context} ] }
209 grep { $_->{type} eq 2 && $_->{server} eq $serv }
211 if (nickcmp get_info('nick'), $nick) {
212 my $oldctxt = get_context;
213 my $host = host $userhost;
215 my $clones = remove $nick, $host, $serv, $_->[0];
217 set_context $_->[1] or next;
218 print $ph clone_leave_str $userhost, $nick, $clones;
221 set_context $oldctxt;
223 flush $serv, $_->[0] for @chans;
228 hook_print 'Disconnected', sub {
229 my %servers = map { $_->{server} => 1 }
230 grep { $_->{flags} & 9 && not $_->{flags} & 2 }
232 delete $users{$_} for grep { !$servers{$_} } keys %users;
233 delete $fetched{$_} for grep { !$servers{$_} } keys %fetched;
238 my ($old, $new) = @{$_[0]};
239 my $userinfo = user_info $new;
240 replace $old => $new, host($userinfo->{host}),
241 get_info('server'), lc get_info('channel') if $userinfo;
245 hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');
247 hook_command 'CLSCAN', sub {
248 my ($serv, $chan) = (get_info('server'), lc get_info('channel'));
249 if (!$fetched{$serv}{$chan} && !fetch($serv, $chan)) {
250 print $ph "Data still not available\n";
251 } elsif (!scan($serv, $chan)) {
252 print $ph "No clones found\n";
256 help_text => 'Scan for clones in the current channel'
259 $ph = new Xchat::XPI name => 'Clones scanner',
261 desc => 'Automatic & on-demand clones scanner',
262 author => 'Vincent Pit (VPIT)',
263 email => 'perl@profvince.com',
264 url => 'http://www.profvince.com',
265 unload => sub { undef %users };