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;
 270  $servers{$_->{server}} = 1 for grep +($_->{flags} & 0b1011) == 0b1001,
 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;