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