X-Git-Url: http://git.vpit.fr/?p=perl%2Fscripts%2Fxchat.git;a=blobdiff_plain;f=clones.pl;h=5fb37f07c0090ff8b27888c441cada011ea4e06f;hp=a8b01fb24b868f6c3f29bd9502c0ea5d69bfd5fd;hb=HEAD;hpb=263b6777b90548951a13bd56419fa911b010eb9b

diff --git a/clones.pl b/clones.pl
index a8b01fb..5fb37f0 100755
--- a/clones.pl
+++ b/clones.pl
@@ -3,20 +3,23 @@ package Xchat::VPIT::Clones;
 use strict;
 use warnings;
 
-use Scalar::Util qw/dualvar/;
+use Scalar::Util qw<dualvar>;
 
-use Xchat qw/:all/;
+use Xchat qw<:all>;
 
 use lib get_info 'xchatdir';
 use Xchat::XPI;
-use Xchat::XPI::Events qw/delay/;
+use Xchat::XPI::Events qw<delay>;
+use Xchat::XPI::Utils  qw<irc_lc save_context local_context>;
 
 use constant {
  JOIN_DELAY => 1000,
- PRE  => ' ',
- POST => "\n"
+ PRE        => ' ',
+ POST       => "\n",
 };
 
+die 'Invalid PRE/POST' unless irc_lc(PRE . POST) eq PRE . POST;
+
 our $VERSION = '0.04';
 
 my ($ph, %users, %fetched);
@@ -25,13 +28,17 @@ $extractor = qr/$extractor/;
 
 sub clone_enter_str {
  my ($host, $nick, $clones) = @_;
- my @clones = $clones =~ /$extractor/g;
+
+ my @clones = $clones =~ /$extractor/go;
+
  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;
+
+ my @clones = $clones =~ /$extractor/go;
+
  return "\002$nick\002 ($host) has "
                        . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
                        . " left : \002@clones\002\n";
@@ -39,46 +46,59 @@ sub clone_leave_str {
 
 sub clone_list_str {
  my ($host, $clones) = @_;
- my @clones = $clones =~ /$extractor/g;
+
+ my @clones = $clones =~ /$extractor/go;
+
  return "Clones ($host) : \002@clones\002\n";
 }
 
 sub host {
  my $userhost = lc $_[0];
- my ($host) = $userhost =~ /@([^@]+)$/;
- return $host || $userhost;
+
+ return $userhost =~ /@([^@]+)$/ ? strip_code($1) : $userhost;
 }
 
 sub add {
  my ($nick, $host, $serv, $chan) = @_;
- my $hosts = $users{$serv}{$chan};
- $users{$serv}{$chan} = $hosts = { } if not defined $hosts;
+
+ $chan = irc_lc $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) < $[) {
+  if (index(irc_lc($clones), irc_lc($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};
+
+ $nick = irc_lc $nick;
+ $chan = irc_lc $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) >= $[) {
+ if ((my $off = index irc_lc($clones), $nick) >= $[) {
   my $count = int $clones;
   if ($count > 1) {
    substr $clones, $off, length $nick, '';
-   return $hosts->{$host} = dualvar $count - 1,
-                                    $clones;
+   return $hosts->{$host} = dualvar $count - 1, $clones;
   } else {
    delete $hosts->{$host};
   }
@@ -88,11 +108,17 @@ sub remove {
 
 sub replace {
  my ($old, $new, $host, $serv, $chan) = @_;
+
+ $old  = irc_lc $old;
+ $chan = irc_lc $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) >= $[) {
+
+ $_ = PRE . $_ . POST for $old, $new;
+ if (defined $clones and (my $off = index irc_lc($clones), $old) >= $[) {
   my $count = int $clones;
   substr $clones, $off, length $old, '';
   $hosts->{$host} = dualvar $count, $clones . $new;
@@ -103,8 +129,12 @@ sub replace {
 
 sub scan {
  my ($serv, $chan) = @_;
+
+ $chan = irc_lc $chan;
+
  return unless $fetched{$serv}{$chan};
  my $hosts = $users{$serv}{$chan};
+
  my $count = 0;
  while (my ($host, $clones) = each %$hosts) {
   if ($clones > 1) {
@@ -112,39 +142,53 @@ sub scan {
    print $ph clone_list_str $host, $clones;
   }
  }
+
  return $count;
 }
 
 sub flush {
  my ($serv, $chan) = @_;
- return 0 unless $serv && $chan && $fetched{$serv}{$chan};
+
+ return 0 unless $serv and $chan;
+
+ $chan = irc_lc $chan;
+ return 0 unless $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;
+
+ my $users = 0;
+ for (get_list 'users') {
+  my $host = $_->{host};
+  next unless defined $host and length $host;
+  add $_->{nick}, host($host), $serv, $chan;
+  ++$users;
  }
- return scalar @users;
+ $fetched{$serv}{irc_lc($chan)} = 1 if $users;
+
+ return $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;
+ my $chan = $_[0][3];
+
+ return EAT_NONE if $fetched{$serv}{irc_lc($chan)};
+
+ local_context $chan, $serv => sub {
+  fetch $serv, $chan;
+  scan  $serv, $chan;
+ };
+
  return EAT_NONE;
 };
 
@@ -154,63 +198,69 @@ hook_server '315', sub { # WHO end
 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 $chan = 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 unless $clones > 0;
+
+ my $printer = sub {
+  print $ph clone_enter_str $userhost, $nick, $clones;
+  1
+ };
+
+ local_context $chan, $serv, $printer or delay JOIN_DELAY, sub {
+  local_context $chan, $serv, $printer;
+ };
+
  return EAT_NONE;
 };
 
 hook_server 'KICK', sub {
  my $nick = $_[0][3];
  my $serv = get_info 'server';
- my $chan = lc $_[0][2];
+ my $chan = $_[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;
+  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];
+ my $chan = $_[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 }
+ my $serv  = get_info 'server';
+ my @chans = map [ $_->{channel}, $_->{context} ],
+              grep { $_->{type} == 2 and $_->{server} eq $serv }
                get_list 'channels';
+
  if (nickcmp get_info('nick'), $nick) {
-  my $oldctxt = get_context;
-  my $host = host $userhost;
+  my $guard = save_context;
+  my $host  = host $userhost;
   for (@chans) {
    my $clones = remove $nick, $host, $serv, $_->[0];
    if ($clones > 0) {
@@ -218,50 +268,71 @@ hook_server 'QUIT', sub {
     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;
+ my %servers;
+ $servers{$_->{server}} = 1 for grep +($_->{flags} & 0b1011) == 0b1001,
+                                 get_list 'channels';
+
+ delete @users{  grep !$servers{$_}, keys %users};
+ delete @fetched{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;
+ $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'), get_info('channel');
+ }
+
  return EAT_NONE;
 }
 
-hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');
+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)) {
+ my $serv = get_info 'server';
+ my $chan = get_info 'channel';
+
+ if (!$fetched{$serv}{irc_lc($chan)} and !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 };
+$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;
+  undef %fetched;
+ },
+);
 
 1;