+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];
+ my ($host) = $userhost =~ /@([^@]+)$/;
+ return $host || $userhost;
+}
+
+sub add {
+ my ($nick, $host, $serv, $chan) = @_;
+ my $hosts = $users{$serv}{$chan};
+ $users{$serv}{$chan} = $hosts = { } if not 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;
+ return EAT_NONE unless $userinfo;
+ my $userhost = $userinfo->{host};
+ 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;
+ replace $old => $new, host($userinfo->{host}),
+ get_info('server'), lc get_info('channel') if $userinfo;
+ return EAT_NONE;
+}
+
+hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');
+
+hook_command 'CLSCAN', sub {
+ my ($serv, $chan) = (get_info('server'), 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 = new Xchat::XPI 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;