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 = { } 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; 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, $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 = 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;