package Xchat::VPIT::Clones;

use strict;
use warnings;

use Scalar::Util qw<dualvar>;

use Xchat qw<:all>;

use lib get_info 'xchatdir';
use Xchat::XPI;
use Xchat::XPI::Events qw<delay>;

use constant {
 JOIN_DELAY => 1000,
 PRE  => ' ',
 POST => "\n"
};

our $VERSION = '0.04';

my ($ph, %users, %fetched);
my $extractor = PRE . '(.+?)' . POST;
$extractor = qr/$extractor/;

sub clone_enter_str {
 my ($host, $nick, $clones) = @_;
 my @clones = $clones =~ /$extractor/g;
 return "\002$nick\002 ($host) is a clone of : \002@clones\002\n";
}

sub clone_leave_str {
 my ($host, $nick, $clones) = @_;
 my @clones = $clones =~ /$extractor/g;
 return "\002$nick\002 ($host) has "
                       . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
                       . " left : \002@clones\002\n";
}

sub clone_list_str {
 my ($host, $clones) = @_;
 my @clones = $clones =~ /$extractor/g;
 return "Clones ($host) : \002@clones\002\n";
}

sub host {
 my $userhost = lc $_[0];
 return $userhost =~ /@([^@]+)$/ ? $1 : $userhost;
}

sub add {
 my ($nick, $host, $serv, $chan) = @_;
 my $hosts = $users{$serv}{$chan};
 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
 my $clones = $hosts->{$host};
 $nick = PRE . $nick . POST;
 if (defined $clones) {
  if (index($clones, $nick) < $[) {
   $hosts->{$host} = dualvar int($clones) + 1, $clones . $nick;
  }
 } else {
  $clones = dualvar 0, '';
  $hosts->{$host} = dualvar 1, $nick;
 }
 return $clones;
}

sub remove {
 my ($nick, $host, $serv, $chan) = @_;
 my $hosts = $users{$serv}{$chan};
 return 0 unless $hosts;
 my $clones = $hosts->{$host};
 return 0 unless $clones;
 $nick = PRE . $nick . POST;
 if ((my $off = index $clones, $nick) >= $[) {
  my $count = int $clones;
  if ($count > 1) {
   substr $clones, $off, length $nick, '';
   return $hosts->{$host} = dualvar $count - 1,
                                    $clones;
  } else {
   delete $hosts->{$host};
  }
 }
 return 0;
}

sub replace {
 my ($old, $new, $host, $serv, $chan) = @_;
 my $hosts = $users{$serv}{$chan};
 $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
 my $clones = $hosts->{$host};
 ($old, $new) = map { PRE . $_ . POST } $old, $new;
 if (defined $clones && (my $off = index $clones, $old) >= $[) {
  my $count = int $clones;
  substr $clones, $off, length $old, '';
  $hosts->{$host} = dualvar $count, $clones . $new;
 } else {
  $hosts->{$host} = dualvar 1, $new;
 }
}

sub scan {
 my ($serv, $chan) = @_;
 return unless $fetched{$serv}{$chan};
 my $hosts = $users{$serv}{$chan};
 my $count = 0;
 while (my ($host, $clones) = each %$hosts) {
  if ($clones > 1) {
   ++$count;
   print $ph clone_list_str $host, $clones;
  }
 }
 return $count;
}

sub flush {
 my ($serv, $chan) = @_;
 return 0 unless $serv && $chan && $fetched{$serv}{$chan};
 delete $users{$serv}{$chan};
 delete $users{$serv} unless keys %{$users{$serv}};
 delete $fetched{$serv}{$chan};
 delete $fetched{$serv} unless keys %{$fetched{$serv}};
 return 1;
}

sub fetch {
 my ($serv, $chan) = @_;
 my @users = grep { defined $_->{host} and length $_->{host} }
              get_list 'users';
 if (@users) {
  add $_->{nick}, host($_->{host}), $serv, $chan for @users;
  $fetched{$serv}{$chan} = 1;
 }
 return scalar @users;
}

hook_server '315', sub { # WHO end
 my $serv = get_info 'server';
 my $chan = lc $_[0][3];
 return EAT_NONE if $fetched{$serv}{$chan};
 my $oldctxt = get_context;
 set_context $chan, $serv or return EAT_NONE;
 fetch $serv, $chan;
 scan $serv, $chan;
 set_context $oldctxt;
 return EAT_NONE;
};

# On join, the who finishes sometimes before the tab opens, so the scan result
# isn't always displayed in the proper context. Hence the delay()

hook_server 'JOIN', sub {
 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
 my $serv = get_info 'server';
 my $chan = lc substr $_[0][2], 1; # starts with colon
 my $clones = add $nick, host($userhost), $serv, $chan;
 if ($clones > 0) {
  my $oldctxt = get_context;
  if (set_context $chan, $serv) {
   print $ph clone_enter_str $userhost, $nick, $clones;
   set_context $oldctxt;
  } else {
   delay JOIN_DELAY, sub {
    my $oldctxt = get_context;
    return unless set_context $chan, $serv;
    print $ph clone_enter_str $userhost, $nick, $clones;
    set_context $oldctxt;
   };
  }
 }
 return EAT_NONE;
};

hook_server 'KICK', sub {
 my $nick = $_[0][3];
 my $serv = get_info 'server';
 my $chan = lc $_[0][2];
 if (nickcmp get_info('nick'), $nick) {
  my $userinfo = user_info $nick;
  my $userhost = $userinfo->{host};
  if (defined $userhost and length $userhost) {
   # If this isn't true, the kick happened before the first WHO response was
   # received and the nick isn't in the database yet.
   my $clones = remove $nick, host($userhost), $serv, $chan;
   print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
  }
 } else {
  flush $serv, $chan;
 }
 return EAT_NONE;
};

hook_server 'PART', sub {
 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
 my $serv = get_info 'server';
 my $chan = lc $_[0][2];
 if (nickcmp get_info('nick'), $nick) {
  my $clones = remove $nick, host($userhost), $serv, $chan;
  print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
 } else {
  flush $serv, $chan;
 }
 return EAT_NONE;
};

hook_server 'QUIT', sub {
 my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
 my $serv = get_info 'server';
 my @chans = map { [ lc $_->{channel}, $_->{context} ] }
              grep { $_->{type} eq 2 && $_->{server} eq $serv }
               get_list 'channels';
 if (nickcmp get_info('nick'), $nick) {
  my $oldctxt = get_context;
  my $host = host $userhost;
  for (@chans) {
   my $clones = remove $nick, $host, $serv, $_->[0];
   if ($clones > 0) {
    set_context $_->[1] or next;
    print $ph clone_leave_str $userhost, $nick, $clones;
   }
  }
  set_context $oldctxt;
 } else {
  flush $serv, $_->[0] for @chans;
 }
 return EAT_NONE;
};

hook_print 'Disconnected', sub {
 my %servers = map { $_->{server} => 1 }
                grep { $_->{flags} & 9 && not $_->{flags} & 2 }
                 get_list 'channels';
 delete $users{$_}   for grep { !$servers{$_} } keys %users;
 delete $fetched{$_} for grep { !$servers{$_} } keys %fetched;
 return EAT_NONE;
};

sub nick_cb {
 my ($old, $new) = @{$_[0]};
 my $userinfo = user_info $new;
 $userinfo    = user_info $old unless defined $userinfo;
 my $userhost = $userinfo->{host};
 if (defined $userhost and length $userhost) {
  # If the host isn't defined, the first WHO response hasn't been received yet,
  # so the old nick isn't even in our database.
  # Otherwise, the new nick would be added right now, and the old one would be
  # when the WHO responses arrives (which may still refer to the old nick).
  replace $old => $new, host($userhost),
                        get_info('server'), lc get_info('channel');
 }
 return EAT_NONE;
}

hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');

hook_command 'CLSCAN', sub {
 my $serv = get_info 'server';
 my $chan = lc get_info 'channel';
 if (!$fetched{$serv}{$chan} && !fetch($serv, $chan)) {
  print $ph "Data still not available\n";
 } elsif (!scan($serv, $chan)) {
  print $ph "No clones found\n";
 }
 return EAT_ALL;
}, {
 help_text => 'Scan for clones in the current channel'
};

$ph = Xchat::XPI->new(
 name   => 'Clones scanner',
 tag    => 'Clones',
 desc   => 'Automatic & on-demand clones scanner',
 author => 'Vincent Pit (VPIT)',
 email  => 'perl@profvince.com',
 url    => 'http://www.profvince.com',
 unload => sub { undef %users },
);

1;
