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;