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 = { } if not 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   return EAT_NONE unless $userinfo;
 182   my $userhost = $userinfo->{host};
 183   my $clones = remove $nick, host($userhost), $serv, $chan;
 184   print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
 185  } else {
 186   flush $serv, $chan;
 187  }
 188  return EAT_NONE;
 189 };
 190
 191 hook_server 'PART', sub {
 192  my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
 193  my $serv = get_info 'server';
 194  my $chan = lc $_[0][2];
 195  if (nickcmp get_info('nick'), $nick) {
 196   my $clones = remove $nick, host($userhost), $serv, $chan;
 197   print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
 198  } else {
 199   flush $serv, $chan;
 200  }
 201  return EAT_NONE;
 202 };
 203
 204 hook_server 'QUIT', sub {
 205  my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
 206  my $serv = get_info 'server';
 207  my @chans = map { [ lc $_->{channel}, $_->{context} ] }
 208               grep { $_->{type} eq 2 && $_->{server} eq $serv }
 209                get_list 'channels';
 210  if (nickcmp get_info('nick'), $nick) {
 211   my $oldctxt = get_context;
 212   my $host = host $userhost;
 213   for (@chans) {
 214    my $clones = remove $nick, $host, $serv, $_->[0];
 215    if ($clones > 0) {
 216     set_context $_->[1] or next;
 217     print $ph clone_leave_str $userhost, $nick, $clones;
 218    }
 219   }
 220   set_context $oldctxt;
 221  } else {
 222   flush $serv, $_->[0] for @chans;
 223  }
 224  return EAT_NONE;
 225 };
 226
 227 hook_print 'Disconnected', sub {
 228  my %servers = map { $_->{server} => 1 }
 229                 grep { $_->{flags} & 9 && not $_->{flags} & 2 }
 230                  get_list 'channels';
 231  delete $users{$_} for grep { !$servers{$_} } keys %users;
 232  delete $fetched{$_} for grep { !$servers{$_} } keys %fetched;
 233  return EAT_NONE;
 234 };
 235
 236 sub nick_cb {
 237  my ($old, $new) = @{$_[0]};
 238  my $userinfo = user_info $new;
 239  replace $old => $new, host($userinfo->{host}),
 240                        get_info('server'), lc get_info('channel') if $userinfo;
 241  return EAT_NONE;
 242 }
 243
 244 hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');
 245
 246 hook_command 'CLSCAN', sub {
 247  my ($serv, $chan) = (get_info('server'), lc get_info('channel'));
 248  if (!$fetched{$serv}{$chan} && !fetch($serv, $chan)) {
 249   print $ph "Data still not available\n";
 250  } elsif (!scan($serv, $chan)) {
 251   print $ph "No clones found\n";
 252  }
 253  return EAT_ALL;
 254 }, {
 255  help_text => 'Scan for clones in the current channel'
 256 };
 257
 258 $ph = Xchat::XPI->new(
 259  name   => 'Clones scanner',
 260  tag    => 'Clones',
 261  desc   => 'Automatic & on-demand clones scanner',
 262  author => 'Vincent Pit (VPIT)',
 263  email  => 'perl@profvince.com',
 264  url    => 'http://www.profvince.com',
 265  unload => sub { undef %users },
 266 );
 267
 268 1;