]> git.vpit.fr Git - perl/scripts/xchat.git/blob - clones.pl
Restyle opers.pl
[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
14 use constant {
15  JOIN_DELAY => 1000,
16  PRE        => ' ',
17  POST       => "\n",
18 };
19
20 our $VERSION = '0.04';
21
22 my ($ph, %users, %fetched);
23 my $extractor = PRE . '(.+?)' . POST;
24 $extractor = qr/$extractor/;
25
26 sub clone_enter_str {
27  my ($host, $nick, $clones) = @_;
28
29  my @clones = $clones =~ /$extractor/go;
30
31  return "\002$nick\002 ($host) is a clone of : \002@clones\002\n";
32 }
33
34 sub clone_leave_str {
35  my ($host, $nick, $clones) = @_;
36
37  my @clones = $clones =~ /$extractor/go;
38
39  return "\002$nick\002 ($host) has "
40                        . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
41                        . " left : \002@clones\002\n";
42 }
43
44 sub clone_list_str {
45  my ($host, $clones) = @_;
46
47  my @clones = $clones =~ /$extractor/go;
48
49  return "Clones ($host) : \002@clones\002\n";
50 }
51
52 sub host {
53  my $userhost = lc $_[0];
54
55  return $userhost =~ /@([^@]+)$/ ? $1 : $userhost;
56 }
57
58 sub add {
59  my ($nick, $host, $serv, $chan) = @_;
60
61  my $hosts  = $users{$serv}{$chan};
62  $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
63
64  my $clones = $hosts->{$host};
65
66  $nick = PRE . $nick . POST;
67  if (defined $clones) {
68   if (index($clones, $nick) < $[) {
69    $hosts->{$host} = dualvar int($clones) + 1, $clones . $nick;
70   }
71  } else {
72   $clones = dualvar 0, '';
73   $hosts->{$host} = dualvar 1, $nick;
74  }
75
76  return $clones;
77 }
78
79 sub remove {
80  my ($nick, $host, $serv, $chan) = @_;
81
82  my $hosts  = $users{$serv}{$chan};
83  return 0 unless $hosts;
84
85  my $clones = $hosts->{$host};
86  return 0 unless $clones;
87
88  $nick = PRE . $nick . POST;
89  if ((my $off = index $clones, $nick) >= $[) {
90   my $count = int $clones;
91   if ($count > 1) {
92    substr $clones, $off, length $nick, '';
93    return $hosts->{$host} = dualvar $count - 1, $clones;
94   } else {
95    delete $hosts->{$host};
96   }
97  }
98  return 0;
99 }
100
101 sub replace {
102  my ($old, $new, $host, $serv, $chan) = @_;
103
104  my $hosts = $users{$serv}{$chan};
105  $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
106
107  my $clones = $hosts->{$host};
108
109  $_ = PRE . $_ . POST for $old, $new;
110  if (defined $clones and (my $off = index $clones, $old) >= $[) {
111   my $count = int $clones;
112   substr $clones, $off, length $old, '';
113   $hosts->{$host} = dualvar $count, $clones . $new;
114  } else {
115   $hosts->{$host} = dualvar 1, $new;
116  }
117 }
118
119 sub scan {
120  my ($serv, $chan) = @_;
121
122  return unless $fetched{$serv}{$chan};
123  my $hosts = $users{$serv}{$chan};
124
125  my $count = 0;
126  while (my ($host, $clones) = each %$hosts) {
127   if ($clones > 1) {
128    ++$count;
129    print $ph clone_list_str $host, $clones;
130   }
131  }
132
133  return $count;
134 }
135
136 sub flush {
137  my ($serv, $chan) = @_;
138
139  return 0 unless $serv and $chan and $fetched{$serv}{$chan};
140
141  delete $users{$serv}{$chan};
142  delete $users{$serv} unless keys %{$users{$serv}};
143
144  delete $fetched{$serv}{$chan};
145  delete $fetched{$serv} unless keys %{$fetched{$serv}};
146
147  return 1;
148 }
149
150 sub fetch {
151  my ($serv, $chan) = @_;
152
153  my $users = 0;
154  for (get_list 'users') {
155   my $host = $_->{host};
156   next unless defined $host and length $host;
157   add $_->{nick}, host($host), $serv, $chan;
158   ++$users;
159  }
160  $fetched{$serv}{$chan} = 1 if $users;
161
162  return $users;
163 }
164
165 hook_server '315', sub { # WHO end
166  my $serv = get_info 'server';
167  my $chan = lc $_[0][3];
168
169  return EAT_NONE if $fetched{$serv}{$chan};
170
171  my $oldctxt = get_context;
172  set_context $chan, $serv or return EAT_NONE;
173  fetch $serv, $chan;
174  scan  $serv, $chan;
175  set_context $oldctxt;
176
177  return EAT_NONE;
178 };
179
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()
182
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
187
188  my $clones = add $nick, host($userhost), $serv, $chan;
189  if ($clones > 0) {
190   my $oldctxt = get_context;
191   if (set_context $chan, $serv) {
192    print $ph clone_enter_str $userhost, $nick, $clones;
193    set_context $oldctxt;
194   } else {
195    delay JOIN_DELAY, sub {
196     my $oldctxt = get_context;
197     return unless set_context $chan, $serv;
198     print $ph clone_enter_str $userhost, $nick, $clones;
199     set_context $oldctxt;
200    };
201   }
202  }
203
204  return EAT_NONE;
205 };
206
207 hook_server 'KICK', sub {
208  my $nick = $_[0][3];
209  my $serv = get_info 'server';
210  my $chan = lc $_[0][2];
211
212  if (nickcmp get_info('nick'), $nick) {
213   my $userinfo = user_info $nick;
214   my $userhost = $userinfo->{host};
215   if (defined $userhost and length $userhost) {
216    # If this isn't true, the kick happened before the first WHO response was
217    # received and the nick isn't in the database yet.
218    my $clones = remove $nick, host($userhost), $serv, $chan;
219    print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
220   }
221  } else {
222   flush $serv, $chan;
223  }
224
225  return EAT_NONE;
226 };
227
228 hook_server 'PART', sub {
229  my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
230  my $serv = get_info 'server';
231  my $chan = lc $_[0][2];
232
233  if (nickcmp get_info('nick'), $nick) {
234   my $clones = remove $nick, host($userhost), $serv, $chan;
235   print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
236  } else {
237   flush $serv, $chan;
238  }
239
240  return EAT_NONE;
241 };
242
243 hook_server 'QUIT', sub {
244  my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
245  my $serv  = get_info 'server';
246  my @chans = map [ lc $_->{channel}, $_->{context} ],
247               grep { $_->{type} == 2 and $_->{server} eq $serv }
248                get_list 'channels';
249
250  if (nickcmp get_info('nick'), $nick) {
251   my $oldctxt = get_context;
252   my $host    = host $userhost;
253   for (@chans) {
254    my $clones = remove $nick, $host, $serv, $_->[0];
255    if ($clones > 0) {
256     set_context $_->[1] or next;
257     print $ph clone_leave_str $userhost, $nick, $clones;
258    }
259   }
260   set_context $oldctxt;
261  } else {
262   flush $serv, $_->[0] for @chans;
263  }
264
265  return EAT_NONE;
266 };
267
268 hook_print 'Disconnected', sub {
269  my %servers = map { $_->{server} => 1 }
270                 grep { $_->{flags} & 9 and not($_->{flags} & 2) }
271                  get_list 'channels';
272
273  delete @users{  grep !$servers{$_}, keys %users};
274  delete @fetched{grep !$servers{$_}, keys %fetched};
275
276  return EAT_NONE;
277 };
278
279 sub nick_cb {
280  my ($old, $new) = @{$_[0]};
281
282  my $userinfo = user_info $new;
283  $userinfo    = user_info $old unless defined $userinfo;
284
285  my $userhost = $userinfo->{host};
286  if (defined $userhost and length $userhost) {
287   # If the host isn't defined, the first WHO response hasn't been received yet,
288   # so the old nick isn't even in our database.
289   # Otherwise, the new nick would be added right now, and the old one would be
290   # when the WHO responses arrives (which may still refer to the old nick).
291   replace $old => $new, host($userhost),
292                         get_info('server'), lc get_info('channel');
293  }
294
295  return EAT_NONE;
296 }
297
298 hook_print $_, \&nick_cb for 'Change Nick', 'Your Nick Changing';
299
300 hook_command 'CLSCAN', sub {
301  my $serv = get_info 'server';
302  my $chan = lc get_info 'channel';
303
304  if (!$fetched{$serv}{$chan} and !fetch($serv, $chan)) {
305   print $ph "Data still not available\n";
306  } elsif (!scan($serv, $chan)) {
307   print $ph "No clones found\n";
308  }
309
310  return EAT_ALL;
311 }, {
312  help_text => 'Scan for clones in the current channel'
313 };
314
315 $ph = Xchat::XPI->new(
316  name   => 'Clones scanner',
317  tag    => 'Clones',
318  desc   => 'Automatic & on-demand clones scanner',
319  author => 'Vincent Pit (VPIT)',
320  email  => 'perl@profvince.com',
321  url    => 'http://www.profvince.com',
322  unload => sub { undef %users },
323 );
324
325 1;