X-Git-Url: https://git.octo.it/?a=blobdiff_plain;f=lib%2FOnis%2FData%2FCore.pm;h=d1e3fefafb4a5254c81d8959592d9c11f240a261;hb=a079fa409a73daae8465928b8855268a40c9b17c;hp=0ff10e995eee02f9d06aa96fef14a6afd4c2d722;hpb=2d842621d5f6150b3adec280a7472e7aabc598d8;p=onis.git diff --git a/lib/Onis/Data/Core.pm b/lib/Onis/Data/Core.pm index 0ff10e9..d1e3fef 100644 --- a/lib/Onis/Data/Core.pm +++ b/lib/Onis/Data/Core.pm @@ -15,28 +15,87 @@ use strict; use warnings; use Exporter; -use Onis::Config qw#get_config#; -use Onis::Users qw#host_to_username nick_to_username#; -use Onis::Data::Persistent qw#init#; - -@Onis::Data::Core::EXPORT_OK = qw#all_nicks get_channel - nick_to_ident - ident_to_nick ident_to_name - get_main_nick - get_total_lines nick_rename print_output - register_plugin store get_print_name#; +use Onis::Config qw(get_config); +use Onis::Users qw(ident_to_name); +use Onis::Data::Persistent; +use Onis::Parser::Persistent qw(get_absolute_time); + +=head1 NAMING CONVENTION + +Each and every person in the IRC can be identified by a three-tupel: B, +B and B, most often seen as I. + +The combination of B and B is called an B here and written +I. The combination of all three parts is called a B here, +though it's rarely used. + +A B is the name of the "user" as defined in the F. Therefore, +the F defines a mapping of B -E B. + +=cut + +our $GeneralCounters = Onis::Data::Persistent->new ('GeneralCounters', 'key', 'value'); +our $NickToIdentCache = Onis::Data::Persistent->new ('NickToIdentCache', 'nick', 'ident'); +our $ChatterList = Onis::Data::Persistent->new ('ChatterList', 'chatter', 'counter'); +our $ChannelNames = Onis::Data::Persistent->new ('ChannelNames', 'channel', 'counter'); + +@Onis::Data::Core::EXPORT_OK = +qw( + store unsharp calculate_nicks + + get_all_nicks get_channel get_main_nick nick_to_ident ident_to_nick nick_to_name + get_total_lines get_most_recent_time nick_rename print_output register_plugin +); @Onis::Data::Core::ISA = ('Exporter'); -our $DATA = init ('$DATA', 'hash'); +our $LinesThisRun = 0; + +our $PluginCallbacks = {}; +our $OutputCallbacks = []; +our @AllNicks = (); + +our %NickToNick = (); +our %NickToIdent = (); +our %IdentToNick = (); + +=head1 CONFIGURATION OPTIONS + +=over 4 + +=item B: I; + +Sets the amount of unsharping onis should do. Valid options are I, +I, I and I. -our $REGISTER = {}; -our $OUTPUT = []; -our @ALLNICKS = (); -our @ALLNAMES = (); -our %NICK_MAP = (); -our %NICK2IDENT = (); -our %IDENT2NICK = (); -our $LASTRUN_DAYS = 0; +=over 4 + +=item I + +does not do any unsharping. + +=item I + +Leaves IP-addresses as they are. The deepest subdomains containing numbers have +those numbers removed. So C becomes +C. + +=item I + +Removes the last byte from IP-adresses. So C<84.56.107.131> becomes +C<84.56.107.*>. Hostnames have the deepest subdomains removed if they contain +numers, so C becomes C<*.arcor-ip.net> while +C is not modified. This is the default and recommended +behavior. + +=item I + +Handles IP-addresses as I. Hostnames have all subdomains removed, so +C becomes C<*.t-dialin.net> and C +becomes C<*.franken.de>. + +=back + +=cut our $UNSHARP = 'MEDIUM'; if (get_config ('unsharp')) @@ -58,32 +117,19 @@ if (get_config ('unsharp')) } } -if (!%$DATA) -{ - $DATA->{'idents_of_nick'} = {}; - $DATA->{'channel'} = {}; - $DATA->{'total_lines'} = 0; -} +=item B: I; -if (defined ($DATA->{'lastrun'})) -{ - my $last = $DATA->{'lastrun'}; - my $now = time; +Sets the name of the channel. This is mostly automatically figured out, use +this if onis doesn't get it right or you want another name.. - my $diff = ($now - $last) % 86400; +=back - if ($diff > 0) - { - $DATA->{'lastrun'} = $now; - $LASTRUN_DAYS = $diff; - } -} -else -{ - $DATA->{'lastrun'} = time; -} +=cut + +# TODO +# - lastrun -my $VERSION = '$Id: Core.pm,v 1.14 2004/10/31 15:00:32 octo Exp $'; +my $VERSION = '$Id$'; print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG); return (1); @@ -92,71 +138,281 @@ return (1); =over 4 -=item I<@nicks> = B () +=item B (I<$type>, I<$data>) -Returns an array of all seen nicks. +Passes I<$data> (a hashref) to all plugins which registered for I<$type>. This +is the actual workhorse when parsing the file since it will be called once for +every line found. + +It will fill I<$data> with I, I and I if these fields are +missing but have been seen for this nick before. =cut -sub all_nicks +sub store { - return (@ALLNICKS); + my $data = shift; + my $type = $data->{'type'}; + my ($nick, $user, $host); + my $ident; + + if (!defined ($type)) + { + print STDERR $/, __FILE__, ": Plugin data did not include a type. This line will be skipped." if ($::DEBUG & 0x20); + return (undef); + } + + if (!defined ($data->{'nick'})) + { + print STDERR $/, __FILE__, ": Plugin data did not include a nick. This line will be skipped." if ($::DEBUG & 0x20); + return (undef); + } + + $nick = $data->{'nick'}; + + if (defined ($data->{'host'})) + { + my $chatter; + my $counter; + + ($user, $host) = unsharp ($data->{'host'}); + $ident = "$user\@$host"; + + $data->{'host'} = $host; + $data->{'user'} = $user; + $data->{'ident'} = $ident; + + $NickToIdentCache->put ($nick, $ident); + + $chatter = "$nick!$ident"; + ($counter) = $ChatterList->get ($chatter); + $counter ||= 0; $counter++; + $ChatterList->put ($chatter, $counter); + } + elsif (($ident) = $NickToIdentCache->get ($nick)) + { + my $chatter = "$nick!$ident"; + my $counter; + ($user, $host) = split (m/@/, $ident); + + $data->{'host'} = $host; + $data->{'user'} = $user; + $data->{'ident'} = $ident; + + ($counter) = $ChatterList->get ($chatter); + $counter ||= 0; $counter++; + $ChatterList->put ($chatter, $counter); + } + else + { + $data->{'host'} = $host = ''; + $data->{'user'} = $user = ''; + $data->{'ident'} = $ident = ''; + } + + if ($::DEBUG & 0x0100) + { + print STDERR $/, __FILE__, ": id ($nick) = ", $ident; + } + + if (defined ($data->{'channel'})) + { + my $chan = lc ($data->{'channel'}); + my ($count) = $ChannelNames->get ($chan); + $count ||= 0; $count++; + $ChannelNames->put ($chan, $count); + } + + if (!defined ($data->{'epoch'})) + { + $data->{'epoch'} = get_absolute_time (); + } + + if ($::DEBUG & 0x400) + { + my @keys = keys (%$data); + for (sort (@keys)) + { + my $key = $_; + my $val = $data->{$key}; + print STDERR $/, __FILE__, ': '; + printf STDERR ("%10s: %s", $key, $val); + } + } + + { + my ($counter) = $GeneralCounters->get ('lines_total'); + $counter ||= 0; + $counter++; + $GeneralCounters->put ('lines_total', $counter); + + my ($time) = $GeneralCounters->get ('most_recent_time'); + $time ||= 0; + $time = $data->{'epoch'} if ($time < $data->{'epoch'}); + $GeneralCounters->put ('most_recent_time', $time); + + $LinesThisRun++; + } + + if (defined ($PluginCallbacks->{$type})) + { + for (@{$PluginCallbacks->{$type}}) + { + $_->($data); + } + } + + return (1); } +=item (I<$user>, I<$host>) = B (I<$ident>) + +Takes an ident (i.e. a user-host-pair, e.g. I or +I) and "unsharps it". The unsharp version is then +returned. + +=cut + +sub unsharp +{ + my $ident = shift; + + my $user; + my $host; + my @parts; + my $num_parts; + my $i; + + print STDERR $/, __FILE__, ": Unsharp ``$ident''" if ($::DEBUG & 0x100); + + ($user, $host) = split (m/@/, $ident, 2); + + @parts = split (m/\./, $host); + $num_parts = scalar (@parts); + + if (($UNSHARP ne 'NONE') + and ($user =~ m/^[\~\^\-\+\=](.+)$/)) + { + $user = $1; + } + + if ($UNSHARP eq 'NONE') + { + return ($user, $host); + } + elsif ($host =~ m/^[\d\.]{7,15}$/) + { + if ($UNSHARP ne 'LIGHT') + { + $parts[-1] = '*'; + } + } + else + { + for ($i = 0; $i < ($num_parts - 2); $i++) + { + if ($UNSHARP eq 'LIGHT') + { + if ($parts[$i] !~ s/\d+/*/g) + { + last; + } + } + elsif ($UNSHARP eq 'MEDIUM') + { + if ($parts[$i] =~ m/\d/) + { + $parts[$i] = '*'; + } + else + { + last; + } + } + else # ($UNSHARP eq 'HARD') + { + $parts[$i] = '*'; + } + } + } + + $host = lc (join ('.', @parts)); + $host =~ s/\*(?:\.\*)+/*/; + + print STDERR " -> ``$user\@$host''" if ($::DEBUG & 0x100); + return ($user, $host); +} + +=item B () + +Iterates over all chatters found so far, trying to figure out which belong to +the same person. This function has to be called before any calls to +B, B, B and B. + +This is normally the step after having parsed all files and before doing any +output. After this function has been run all the other informative functions +return actually usefull information.. + +It does the following: First, it iterates over all chatters and splits them up +into nicks and idents. If a (user)name is found for the ident it (the ident) is +replaced with it (the name). + +In the second step we iterate over all nicks that have been found and +determines the most active ident for each nick. After this has been done each +nick is associated with exactly one ident, but B vice versa. + +The final step is to iterate over all idents and determine the most active nick +for each ident. After some thought you will agree that now each ident exists +only once and so does every nick. + +=cut + sub calculate_nicks { - my @temp = keys (%{$DATA->{'idents_of_nick'}}); - my $nicks_of_ident = {}; + my $nicks = {}; + my $idents = {}; + my $name2nick = {}; + my $name2ident = {}; + + for ($ChatterList->keys ()) + { + my $chatter = $_; + my ($nick, $ident) = split (m/!/, $chatter); + my $name = ident_to_name ($ident); + my ($counter) = $ChatterList->get ($chatter); - print STDERR $/, __FILE__, ': Looking at ', scalar (@temp), ' nicks.' if ($::DEBUG & 0x100); + $nicks->{$nick}{$ident} = 0 unless (defined ($nicks->{$nick}{$ident})); + $nicks->{$nick}{$ident} += $counter; + } - for (@temp) + for (keys %$nicks) { my $this_nick = $_; my $this_ident = 'unidentified'; + my $this_name = ''; my $this_total = 0; my $this_max = 0; - my $this_ident_is_user = 0; - - my @idents = keys (%{$DATA->{'idents_of_nick'}{$this_nick}}); - for (@idents) + for (keys %{$nicks->{$this_nick}}) { my $ident = $_; - my $num = $DATA->{'idents_of_nick'}{$this_nick}{$ident}; - my $newnum; - my $ident_is_user = 1; - - if ($ident =~ m/^[^@]+@.+$/) - { - $ident_is_user = 0; - } + my $name = ident_to_name ($ident); + my $num = $nicks->{$this_nick}{$ident}; $this_total += $num; - $newnum = int ($num * (0.9**$LASTRUN_DAYS)); - if (!$newnum) - { - print STDERR $/, __FILE__, ": Deleting ident ``$ident'' because it's too old." if ($::DEBUG); - delete ($DATA->{'idents_of_nick'}{$this_nick}{$ident}); - if (!keys %{$DATA->{'idents_of_nick'}{$this_nick}}) - { - print STDERR $/, __FILE__, ": Deleting nick ``$this_nick'' because it's too old." if ($::DEBUG); - delete ($DATA->{'idents_of_nick'}{$this_nick}); - } - } - elsif ($ident_is_user) + if ($name) { - if (($num >= $this_max) or !$this_ident_is_user) + if (($num >= $this_max) or !$this_name) { $this_max = $num; $this_ident = $ident; - $this_ident_is_user = 1; + $this_name = $name; } } - elsif ($ident !~ m/\@unidentified$/) + else { - if (($num >= $this_max) and !$this_ident_is_user) + if (($num >= $this_max) and !$this_name) { $this_max = $num; $this_ident = $ident; @@ -168,16 +424,19 @@ sub calculate_nicks if ($this_ident ne 'unidentified') { - if (!$this_ident_is_user and nick_to_username ($this_nick)) + if ($this_name) { - print STDERR $/, __FILE__, ": $this_nick!$this_ident -> " if ($::DEBUG & 0x100); + $name2nick->{$this_name}{$this_nick} = 0 unless (defined ($name2nick->{$this_name}{$this_nick})); + $name2nick->{$this_name}{$this_nick} += $this_total; - $this_ident = nick_to_username ($this_nick); - $this_ident_is_user = 1; - - print STDERR $this_ident if ($::DEBUG & 0x100); + $name2ident->{$this_name}{$this_ident} = 0 unless (defined ($name2nick->{$this_name}{$this_ident})); + $name2ident->{$this_name}{$this_ident} += $this_total; + } + else + { + $idents->{$this_ident}{$this_nick} = 0 unless (defined ($idents->{$this_ident}{$this_nick})); + $idents->{$this_ident}{$this_nick} += $this_total; } - $nicks_of_ident->{$this_ident}{$this_nick} = $this_total; } elsif ($::DEBUG & 0x100) { @@ -185,23 +444,19 @@ sub calculate_nicks } } - @temp = keys (%$nicks_of_ident); - - print STDERR $/, __FILE__, ': Looking at ', scalar (@temp), ' idents.' if ($::DEBUG & 0x100); - - for (@temp) + for (keys %$idents) { my $this_ident = $_; my $this_nick = ''; my $this_max = 0; my @other_nicks = (); - my @nicks = keys (%{$nicks_of_ident->{$this_ident}}); + my @nicks = keys (%{$idents->{$this_ident}}); for (@nicks) { my $nick = $_; - my $num = $nicks_of_ident->{$this_ident}{$nick}; + my $num = $idents->{$this_ident}{$nick}; if ($num > $this_max) { @@ -219,15 +474,84 @@ sub calculate_nicks for (@other_nicks, $this_nick) { - push (@ALLNICKS, $_); - $NICK_MAP{$_} = $this_nick; - $NICK2IDENT{$_} = $this_ident; + push (@AllNicks, $_); + $NickToNick{$_} = $this_nick; + $NickToIdent{$_} = $this_ident; } - $IDENT2NICK{$this_ident} = $this_nick; + $IdentToNick{$this_ident} = $this_nick; + } + + for (keys %$name2nick) + { + my $name = $_; + my $max_num = 0; + my $max_nick = ''; + my $max_ident = ''; + + my @other_nicks = (); + my @other_idents = (); + + for (keys %{$name2nick->{$name}}) + { + my $nick = $_; + my $num = $name2nick->{$name}{$nick}; + + if ($num > $max_num) + { + push (@other_nicks, $max_nick) if ($max_nick); + $max_nick = $nick; + $max_num = $num; + } + else + { + push (@other_nicks, $nick); + } + } + + $max_num = 0; + for (keys %{$name2ident->{$name}}) + { + my $ident = $_; + my $num = $name2ident->{$name}{$ident}; + + if ($num > $max_num) + { + push (@other_idents, $max_ident) if ($max_ident); + $max_ident = $ident; + $max_num = $num; + } + else + { + push (@other_idents, $ident); + } + } + + for (@other_nicks, $max_nick) + { + push (@AllNicks, $_); + $NickToNick{$_} = $max_nick; + $NickToIdent{$_} = $max_ident; + } + + for (@other_idents, $max_ident) + { + $IdentToNick{$_} = $max_nick; + } } } +=item I<@nicks> = B () + +Returns an array of all seen nicks. + +=cut + +sub get_all_nicks +{ + return (@AllNicks); +} + =item I<$channel> = B () Returns the name of the channel we're generating stats for. @@ -236,27 +560,30 @@ Returns the name of the channel we're generating stats for. sub get_channel { - my $chan; + my $chan = '#unknown'; if (get_config ('channel')) { $chan = get_config ('channel'); } - elsif (keys (%{$DATA->{'channel'}})) - { - ($chan) = sort - { - $DATA->{'channel'}{$b} <=> $DATA->{'channel'}{$a} - } (keys (%{$DATA->{'channel'}})); - } else { - $chan = '#unknown'; + my $max = 0; + for ($ChannelNames->keys ()) + { + my $c = $_; + my ($num) = $ChannelNames->get ($c); + if (defined ($num) and ($num > $max)) + { + $max = $num; + $chan = $c; + } + } } # Fix network-safe channel named (RFC 2811) - if ($chan =~ m/^![A-Z0-9]{5}.+/) + if ($chan =~ m/^![A-Z0-9]{5}(.+)/) { - $chan =~ s/[A-Z0-9]{5}//; + $chan = '!' . $1; } return ($chan); @@ -271,9 +598,9 @@ Returns the main nick for I<$nick> or an empty string if the nick is unknown.. sub get_main_nick { my $nick = shift; - if (defined ($NICK_MAP{$nick})) + if (defined ($NickToNick{$nick})) { - return ($NICK_MAP{$nick}); + return ($NickToNick{$nick}); } else { @@ -283,21 +610,31 @@ sub get_main_nick =item I<$ident> = B (I<$nick>) -Returns the ident for this nick or an empty string if unknown. +Returns the ident for this nick or an empty string if unknown. Before +B is run it will use the database to find the most recent +mapping. After B is run the calculated mapping will be used. =cut sub nick_to_ident { my $nick = shift; - if (defined ($NICK2IDENT{$nick})) + my $ident = ''; + + if (%NickToIdent) { - return ($NICK2IDENT{$nick}); + if (defined ($NickToIdent{$nick})) + { + $ident = $NickToIdent{$nick}; + } } else { - return (''); + ($ident) = $NickToIdentCache->get ($nick); + $ident ||= ''; } + + return ($ident); } =item I<$nick> = B (I<$ident>) @@ -310,15 +647,9 @@ sub ident_to_nick { my $ident = shift; - if (!defined ($ident) - or (lc ($ident) eq 'ignore') - or (lc ($ident) eq 'unidentified')) - { - return (''); - } - elsif (defined ($IDENT2NICK{$ident})) + if (defined ($IdentToNick{$ident})) { - return ($IDENT2NICK{$ident}); + return ($IdentToNick{$ident}); } else { @@ -326,64 +657,55 @@ sub ident_to_nick } } -=item I<$name> = B (I<$ident>) +=item I<$name> = B (I<$nick>) -Returns the printable version of the name for the chatter identified by -I<$ident>. Returns an empty string if the ident is not known. +Return the name associated with I<$nick>. This function uses B +(see L). =cut -sub ident_to_name +sub nick_to_name { - my $ident = shift; - my $nick = ident_to_nick ($ident); - my $name; - - if (!$nick) + my $nick = shift; + my $ident = nick_to_ident ($nick); + + if ($ident) + { + return (ident_to_name ($ident)); + } + else { return (''); } - - $name = get_print_name ($nick); - - return ($name); } -=item I<$name> = B (I<$nick>) +=item I<$lines> = B () -Returns the printable version of the name for the nick I<$nick> or I<$nick> if -unknown. +Returns the total number of lines parsed so far. =cut -sub get_print_name +sub get_total_lines { - my $nick = shift; - my $ident = ''; - my $name = $nick; - - if (defined ($NICK2IDENT{$nick})) - { - $ident = $NICK2IDENT{$nick}; - } - - if (($ident !~ m/^[^@]+@.+$/) and $ident) - { - $name = $ident; - } + my ($total) = $GeneralCounters->get ('lines_total'); - return ($name); + return (qw()) unless ($total); + + return ($total, $LinesThisRun); } -=item I<$lines> = B () +=item I<$epoch> = B () -Returns the total number of lines parsed so far. +Returns the epoch of the most recent line received from the parser. =cut -sub get_total_lines +sub get_most_recent_time { - return ($DATA->{'total_lines'}); + my ($time) = $GeneralCounters->get ('most_recent_time'); + $time ||= 0; + + return ($time); } =item B (I<$old_nick>, I<$new_nick>) @@ -396,24 +718,13 @@ sub nick_rename { my $old_nick = shift; my $new_nick = shift; + my $ident; - if (defined ($DATA->{'host_cache'}{$old_nick})) - { - my $host = $DATA->{'host_cache'}{$old_nick}; - $DATA->{'host_cache'}{$new_nick} = $host; - - if (!defined ($DATA->{'hosts_of_nick'}{$new_nick}{$host})) - { - $DATA->{'hosts_of_nick'}{$new_nick}{$host} = 1; - } - } + ($ident) = $NickToIdentCache->get ($old_nick); - if (defined ($DATA->{'byident'}{"$old_nick\@unidentified"})) + if (defined ($ident) and ($ident)) { - # Other data may be overwritten, but I don't care here.. - # This should be a extremely rare case.. - $DATA->{'byident'}{"$new_nick\@unidentified"} = $DATA->{'byident'}{"$old_nick\@unidentified"}; - delete ($DATA->{'byident'}{"$old_nick\@unidentified"}); + $NickToIdentCache->put ($new_nick, $ident); } } @@ -425,7 +736,8 @@ Print the output. Should be called only once.. sub print_output { - if (!$DATA->{'total_lines'}) + # FIXME FIXME FIXME + if (!get_total_lines ()) { print STDERR <<'MESSAGE'; @@ -441,14 +753,11 @@ MESSAGE } calculate_nicks (); - merge_idents (); - for (@$OUTPUT) + for (@$OutputCallbacks) { &$_ (); } - - delete ($DATA->{'byname'}); } =item I<$data> = B (I<$type>, I<$sub_ref>) @@ -472,324 +781,25 @@ sub register_plugin if ($type eq 'OUTPUT') { - push (@$OUTPUT, $sub_ref); + push (@$OutputCallbacks, $sub_ref); } else { - if (!defined ($REGISTER->{$type})) + if (!defined ($PluginCallbacks->{$type})) { - $REGISTER->{$type} = []; + $PluginCallbacks->{$type} = []; } } - push (@{$REGISTER->{$type}}, $sub_ref); + push (@{$PluginCallbacks->{$type}}, $sub_ref); print STDERR $/, __FILE__, ': ', scalar (caller ()), " registered for ``$type''." if ($::DEBUG & 0x800); - - return ($DATA); -} - -=item B (I<$type>, I<$data>) - -Passes I<$data> (a hashref) to all plugins which registered for I<$type>. - -=cut - -sub store -{ - my $data = shift; - my $type = $data->{'type'}; - my $nick; - my $ident; - - if (!defined ($type)) - { - print STDERR $/, __FILE__, ": Plugin data did not include a type. This line will be skipped." if ($::DEBUG & 0x20); - return (undef); - } - - if (!defined ($data->{'nick'})) - { - print STDERR $/, __FILE__, ": Plugin data did not include a nick. This line will be skipped." if ($::DEBUG & 0x20); - return (undef); - } - - $nick = $data->{'nick'}; - - if (defined ($data->{'host'})) - { - my $user = host_to_username ($nick . '!' . $data->{'host'}); - - if ($user) - { - $data->{'ident'} = $user; - $NICK2IDENT{$nick} = $user; - } - else - { - my $host = unsharp ($data->{'host'}); - $data->{'host'} = $host; - $data->{'ident'} = $host; - $NICK2IDENT{$nick} = $host; - } - - if (defined ($DATA->{'byident'}{"$nick\@unidentified"})) - { - my $ident = $data->{'ident'}; - - print STDERR $/, __FILE__, ": Merging ``$nick\@unidentified'' to ``$ident''" if ($::DEBUG & 0x100); - - if (!defined ($DATA->{'byident'}{$ident})) - { - $DATA->{'byident'}{$ident} = {}; - } - - add_hash ($DATA->{'byident'}{$ident}, $DATA->{'byident'}{"$nick\@unidentified"}); - delete ($DATA->{'byident'}{"$nick\@unidentified"}); - } - } - elsif (defined ($NICK2IDENT{$nick})) - { - $data->{'ident'} = $NICK2IDENT{$nick}; - } - else - { - my $user = nick_to_username ($nick); - - if ($user) - { - $data->{'ident'} = $user; - $NICK2IDENT{$nick} = $user; - } - else - { - $data->{'ident'} = $nick . '@unidentified'; - } - } - - $ident = $data->{'ident'}; - - if ($::DEBUG & 0x0100) - { - print STDERR $/, __FILE__, ": id ($nick) = ", $data->{'ident'}; - } - - if (defined ($data->{'channel'})) - { - my $chan = lc ($data->{'channel'}); - $DATA->{'channel'}{$chan}++; - } - - if ($::DEBUG & 0x400) - { - my @keys = keys (%$data); - for (sort (@keys)) - { - my $key = $_; - my $val = $data->{$key}; - print STDERR $/, __FILE__, ': '; - printf STDERR ("%10s: %s", $key, $val); - } - } - - if (lc ($ident) eq "ignore") - { - print STDERR $/, __FILE__, ': Ignoring line from ignored user.' if ($::DEBUG & 0x0100); - return (0); - } - - $DATA->{'idents_of_nick'}{$nick}{$ident}++; - $DATA->{'total_lines'}++; - - if (defined ($REGISTER->{$type})) - { - for (@{$REGISTER->{$type}}) - { - my $sub_ref = $_; - &$sub_ref ($data); - } - } - - return (1); -} - -=item B (I<$ident>) - -Takes an ident (i.e. a user-host-pair, e.g. I or -I) and "unsharps it". The unsharp version is then -returned. - -What unsharp exactly does is described in the F. - -=cut - -sub unsharp -{ - my $user_host = shift; - - my $user; - my $host; - my @parts; - my $num_parts; - my $i; - my $retval; - - print STDERR $/, __FILE__, ": Unsharp ``$user_host''" if ($::DEBUG & 0x100); - - ($user, $host) = split (m/@/, $user_host, 2); - - @parts = split (m/\./, $host); - $num_parts = scalar (@parts); - - if (($UNSHARP ne 'NONE') - and ($user =~ m/^[\~\^\-\+\=](.+)$/)) - { - $user = $1; - } - - if ($UNSHARP eq 'NONE') - { - return ($user . '@' . $host); - } - elsif ($host =~ m/^[\d\.]{7,15}$/) - { - if ($UNSHARP ne 'LIGHT') - { - $parts[-1] = '*'; - } - } - else - { - for ($i = 0; $i < ($num_parts - 2); $i++) - { - if ($UNSHARP eq 'LIGHT') - { - if ($parts[$i] !~ s/\d+/*/g) - { - last; - } - } - elsif ($UNSHARP eq 'MEDIUM') - { - if ($parts[$i] =~ m/\d/) - { - $parts[$i] = '*'; - } - else - { - last; - } - } - else # ($UNSHARP eq 'HARD') - { - $parts[$i] = '*'; - } - } - } - - $host = lc (join ('.', @parts)); - $host =~ s/\*(\.\*)+/*/; - $retval = $user . '@' . $host; - - print STDERR " -> ``$retval''" if ($::DEBUG & 0x100); - return ($retval); -} - -=item B () - -Merges idents. Does magic, don't interfere ;) - -=cut - -sub merge_idents -{ - my @idents = keys (%IDENT2NICK); - - for (@idents) - { - my $ident = $_; - my $name = ident_to_name ($ident); - - if (!defined ($DATA->{'byident'}{$ident})) - { - next; - } - - if (!defined ($DATA->{'byname'}{$name})) - { - $DATA->{'byname'}{$name} = {}; - } - - add_hash ($DATA->{'byname'}{$name}, $DATA->{'byident'}{$ident}); - } -} - -sub add_hash -{ - my $dst = shift; - my $src = shift; - - my @keys = keys (%$src); - - for (@keys) - { - my $key = $_; - my $val = $src->{$key}; - - if (!defined ($dst->{$key})) - { - $dst->{$key} = $val; - } - elsif (!ref ($val)) - { - if ($val =~ m/\D/) - { - # FIXME - print STDERR $/, __FILE__, ": ``$key'' = ``$val''" if ($::DEBUG); - } - else - { - $dst->{$key} += $val; - } - } - elsif (ref ($val) ne ref ($dst->{$key})) - { - print STDERR $/, __FILE__, ": Destination and source type do not match!" if ($::DEBUG); - } - elsif (ref ($val) eq "HASH") - { - add_hash ($dst->{$key}, $val); - } - elsif (ref ($val) eq "ARRAY") - { - my $i = 0; - for (@$val) - { - my $j = $_; - if ($j =~ m/\D/) - { - # FIXME - print STDERR $/, __FILE__, ": ``", $key, '[', $i, "]'' = ``$j''" if ($::DEBUG); - } - else - { - $dst->{$key}->[$i] += $j; - } - $i++; - } - } - else - { - my $type = ref ($val); - print STDERR $/, __FILE__, ": Reference type ``$type'' is not supported!", $/; - } - } } =back =head1 AUTHOR - Florian octo Forster Eocto at verplant.orgE +Florian octo Forster Eocto at verplant.orgE =cut