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