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