Make sure local_context() runs the code only when the context was found
[perl/scripts/xchat.git] / clones.pl
1 package Xchat::VPIT::Clones;
2
3 use strict;
4 use warnings;
5
6 use Scalar::Util qw<dualvar>;
7
8 use Xchat qw<:all>;
9
10 use lib get_info 'xchatdir';
11 use Xchat::XPI;
12 use Xchat::XPI::Events qw<delay>;
13 use Xchat::XPI::Utils  qw<irc_lc save_context local_context>;
14
15 use constant {
16  JOIN_DELAY => 1000,
17  PRE        => ' ',
18  POST       => "\n",
19 };
20
21 die 'Invalid PRE/POST' unless irc_lc(PRE . POST) eq PRE . POST;
22
23 our $VERSION = '0.04';
24
25 my ($ph, %users, %fetched);
26 my $extractor = PRE . '(.+?)' . POST;
27 $extractor = qr/$extractor/;
28
29 sub clone_enter_str {
30  my ($host, $nick, $clones) = @_;
31
32  my @clones = $clones =~ /$extractor/go;
33
34  return "\002$nick\002 ($host) is a clone of : \002@clones\002\n";
35 }
36
37 sub clone_leave_str {
38  my ($host, $nick, $clones) = @_;
39
40  my @clones = $clones =~ /$extractor/go;
41
42  return "\002$nick\002 ($host) has "
43                        . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
44                        . " left : \002@clones\002\n";
45 }
46
47 sub clone_list_str {
48  my ($host, $clones) = @_;
49
50  my @clones = $clones =~ /$extractor/go;
51
52  return "Clones ($host) : \002@clones\002\n";
53 }
54
55 sub host {
56  my $userhost = lc $_[0];
57
58  return $userhost =~ /@([^@]+)$/ ? strip_code($1) : $userhost;
59 }
60
61 sub add {
62  my ($nick, $host, $serv, $chan) = @_;
63
64  $chan = irc_lc $chan;
65
66  my $hosts  = $users{$serv}{$chan};
67  $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
68
69  my $clones = $hosts->{$host};
70
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;
75   }
76  } else {
77   $clones = dualvar 0, '';
78   $hosts->{$host} = dualvar 1, $nick;
79  }
80
81  return $clones;
82 }
83
84 sub remove {
85  my ($nick, $host, $serv, $chan) = @_;
86
87  $nick = irc_lc $nick;
88  $chan = irc_lc $chan;
89
90  my $hosts  = $users{$serv}{$chan};
91  return 0 unless $hosts;
92
93  my $clones = $hosts->{$host};
94  return 0 unless $clones;
95
96  $nick = PRE . $nick . POST;
97  if ((my $off = index irc_lc($clones), $nick) >= $[) {
98   my $count = int $clones;
99   if ($count > 1) {
100    substr $clones, $off, length $nick, '';
101    return $hosts->{$host} = dualvar $count - 1, $clones;
102   } else {
103    delete $hosts->{$host};
104   }
105  }
106  return 0;
107 }
108
109 sub replace {
110  my ($old, $new, $host, $serv, $chan) = @_;
111
112  $old  = irc_lc $old;
113  $chan = irc_lc $chan;
114
115  my $hosts = $users{$serv}{$chan};
116  $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
117
118  my $clones = $hosts->{$host};
119
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;
125  } else {
126   $hosts->{$host} = dualvar 1, $new;
127  }
128 }
129
130 sub scan {
131  my ($serv, $chan) = @_;
132
133  $chan = irc_lc $chan;
134
135  return unless $fetched{$serv}{$chan};
136  my $hosts = $users{$serv}{$chan};
137
138  my $count = 0;
139  while (my ($host, $clones) = each %$hosts) {
140   if ($clones > 1) {
141    ++$count;
142    print $ph clone_list_str $host, $clones;
143   }
144  }
145
146  return $count;
147 }
148
149 sub flush {
150  my ($serv, $chan) = @_;
151
152  return 0 unless $serv and $chan;
153
154  $chan = irc_lc $chan;
155  return 0 unless $fetched{$serv}{$chan};
156
157  delete $users{$serv}{$chan};
158  delete $users{$serv} unless keys %{$users{$serv}};
159
160  delete $fetched{$serv}{$chan};
161  delete $fetched{$serv} unless keys %{$fetched{$serv}};
162
163  return 1;
164 }
165
166 sub fetch {
167  my ($serv, $chan) = @_;
168
169  my $users = 0;
170  for (get_list 'users') {
171   my $host = $_->{host};
172   next unless defined $host and length $host;
173   add $_->{nick}, host($host), $serv, $chan;
174   ++$users;
175  }
176  $fetched{$serv}{irc_lc($chan)} = 1 if $users;
177
178  return $users;
179 }
180
181 hook_server '315', sub { # WHO end
182  my $serv = get_info 'server';
183  my $chan = $_[0][3];
184
185  return EAT_NONE if $fetched{$serv}{irc_lc($chan)};
186
187  local_context $chan, $serv => sub {
188   fetch $serv, $chan;
189   scan  $serv, $chan;
190  };
191
192  return EAT_NONE;
193 };
194
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()
197
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
202
203  my $clones = add $nick, host($userhost), $serv, $chan;
204  return EAT_NONE unless $clones > 0;
205
206  my $printer = sub {
207   print $ph clone_enter_str $userhost, $nick, $clones;
208   1
209  };
210
211  local_context $chan, $serv, $printer or delay JOIN_DELAY, sub {
212   local_context $chan, $serv, $printer;
213  };
214
215  return EAT_NONE;
216 };
217
218 hook_server 'KICK', sub {
219  my $nick = $_[0][3];
220  my $serv = get_info 'server';
221  my $chan = $_[0][2];
222
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;
231   }
232  } else {
233   flush $serv, $chan;
234  }
235
236  return EAT_NONE;
237 };
238
239 hook_server 'PART', sub {
240  my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
241  my $serv = get_info 'server';
242  my $chan = $_[0][2];
243
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;
247  } else {
248   flush $serv, $chan;
249  }
250
251  return EAT_NONE;
252 };
253
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 }
259                get_list 'channels';
260
261  if (nickcmp get_info('nick'), $nick) {
262   my $guard = save_context;
263   my $host  = host $userhost;
264   for (@chans) {
265    my $clones = remove $nick, $host, $serv, $_->[0];
266    if ($clones > 0) {
267     set_context $_->[1] or next;
268     print $ph clone_leave_str $userhost, $nick, $clones;
269    }
270   }
271  } else {
272   flush $serv, $_->[0] for @chans;
273  }
274
275  return EAT_NONE;
276 };
277
278 hook_print 'Disconnected', sub {
279  my %servers;
280  $servers{$_->{server}} = 1 for grep +($_->{flags} & 0b1011) == 0b1001,
281                                  get_list 'channels';
282
283  delete @users{  grep !$servers{$_}, keys %users};
284  delete @fetched{grep !$servers{$_}, keys %fetched};
285
286  return EAT_NONE;
287 };
288
289 sub nick_cb {
290  my ($old, $new) = @{$_[0]};
291
292  my $userinfo = user_info $new;
293  $userinfo    = user_info $old unless defined $userinfo;
294
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');
303  }
304
305  return EAT_NONE;
306 }
307
308 hook_print $_, \&nick_cb for 'Change Nick', 'Your Nick Changing';
309
310 hook_command 'CLSCAN', sub {
311  my $serv = get_info 'server';
312  my $chan = get_info 'channel';
313
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";
318  }
319
320  return EAT_ALL;
321 }, {
322  help_text => 'Scan for clones in the current channel'
323 };
324
325 $ph = Xchat::XPI->new(
326  name   => 'Clones scanner',
327  tag    => 'Clones',
328  desc   => 'Automatic & on-demand clones scanner',
329  author => 'Vincent Pit (VPIT)',
330  email  => 'perl@profvince.com',
331  url    => 'http://www.profvince.com',
332  unload => sub {
333   undef %users;
334   undef %fetched;
335  },
336 );
337
338 1;