1 package Onis::Data::Core;
5 Onis::Data::Core - User management
9 Store data to the internal structure, care about users, nicks and idents and
10 dispatch to plugins. The core of the data even..
18 use Onis::Config qw(get_config);
19 use Onis::Users qw(ident_to_name);
20 use Onis::Data::Persistent;
21 use Onis::Parser::Persistent qw(get_absolute_time);
23 =head1 NAMING CONVENTION
25 Each and every person in the IRC can be identified by a three-tupel: B<nick>,
26 B<user> and B<host>, most often seen as I<nick!user@host>.
28 The combination of B<user> and B<host> is called an B<ident> here and written
29 I<user@host>. The combination of all three parts is called a B<chatter> here,
30 though it's rarely used.
32 A B<name> is the name of the "user" as defined in the F<users.conf>. Therefore,
33 the F<users.conf> defines a mapping of B<chatter> -E<gt> B<name>.
37 our $Nick2Ident = Onis::Data::Persistent->new ('Nick2Ident', 'nick', 'ident');
38 our $ChatterList = Onis::Data::Persistent->new ('ChatterList', 'chatter', 'counter');
39 our $ChannelNames = Onis::Data::Persistent->new ('ChannelNames', 'channel', 'counter');
41 @Onis::Data::Core::EXPORT_OK =
43 store unsharp calculate_nicks
45 get_all_nicks get_channel get_main_nick nick_to_ident ident_to_nick
46 get_total_lines nick_rename print_output register_plugin merge_idents
48 @Onis::Data::Core::ISA = ('Exporter');
50 our $DATA = init ('$DATA', 'hash');
52 our $PluginCallbacks = {};
58 our %NickToIdent = ();
59 our %IdentToNick = ();
61 our $LASTRUN_DAYS = 0;
65 our $UNSHARP = 'MEDIUM';
66 if (get_config ('unsharp'))
68 my $tmp = get_config ('unsharp');
72 if ($tmp eq 'NONE' or $tmp eq 'LIGHT'
80 print STDERR $/, __FILE__, ": ``$tmp'' is not a valid value for config option ``unsharp''.",
81 $/, __FILE__, ": Using standard value ``MEDIUM''.";
87 $DATA->{'idents_of_nick'} = {};
88 $DATA->{'channel'} = {};
89 $DATA->{'total_lines'} = 0;
92 if (defined ($DATA->{'lastrun'}))
94 my $last = $DATA->{'lastrun'};
97 my $diff = ($now - $last) % 86400;
101 $DATA->{'lastrun'} = $now;
102 $LASTRUN_DAYS = $diff;
107 $DATA->{'lastrun'} = time;
110 my $VERSION = '$Id: Core.pm,v 1.14 2004/10/31 15:00:32 octo Exp $';
111 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
115 =head1 EXPORTED FUNCTIONS
119 =item B<store> (I<$type>, I<$data>)
121 Passes I<$data> (a hashref) to all plugins which registered for I<$type>. This
122 is the actual workhorse when parsing the file since it will be called once for
125 It will fill I<$data> with I<host>, I<user> and I<ident> if these fields are
126 missing but have been seen for this nick before.
133 my $type = $data->{'type'};
134 my ($nick, $user, $host);
137 if (!defined ($type))
139 print STDERR $/, __FILE__, ": Plugin data did not include a type. This line will be skipped." if ($::DEBUG & 0x20);
143 if (!defined ($data->{'nick'}))
145 print STDERR $/, __FILE__, ": Plugin data did not include a nick. This line will be skipped." if ($::DEBUG & 0x20);
149 $nick = $data->{'nick'};
151 if (defined ($data->{'host'}))
156 ($user, $host) = unsharp ($data->{'host'});
157 $ident = "$user\@$host";
159 $data->{'host'} = $host;
160 $data->{'user'} = $user;
161 $data->{'ident'} = $ident;
163 $Nick2Ident->put ($nick, $ident);
165 $chatter = "$nick!$ident";
166 ($counter) = $ChatterList->get ($chatter);
167 $counter ||= 0; $counter++;
168 $ChatterList->put ($chatter, $counter);
170 elsif (($ident) = $Nick2Ident->get ($nick))
172 my $chatter = "$nick!$ident";
173 ($user, $host) = split (m/@/, $ident);
175 $data->{'host'} = $host;
176 $data->{'user'} = $user;
177 $data->{'ident'} = $ident;
179 ($counter) = $ChatterList->get ($chatter);
180 $counter ||= 0; $counter++;
181 $ChatterList->put ($chatter, $counter);
185 $data->{'host'} = $host = '';
186 $data->{'user'} = $user = '';
187 $data->{'ident'} = $ident = '';
190 if ($::DEBUG & 0x0100)
192 print STDERR $/, __FILE__, ": id ($nick) = ", $ident;
195 if (defined ($data->{'channel'}))
197 my $chan = lc ($data->{'channel'});
198 my ($count) = $ChannelNames->get ($chan);
199 $count ||= 0; $count++;
200 $ChannelNames->put ($chan, $count);
203 if (!defined ($data->{'epoch'}))
205 $data->{'epoch'} = get_absolute_time ();
208 if ($::DEBUG & 0x400)
210 my @keys = keys (%$data);
214 my $val = $data->{$key};
215 print STDERR $/, __FILE__, ': ';
216 printf STDERR ("%10s: %s", $key, $val);
221 #$DATA->{'total_lines'}++;
223 if (defined ($PluginCallbacks->{$type}))
225 for (@{$PluginCallbacks->{$type}})
234 =item (I<$user>, I<$host>) = B<unsharp> (I<$ident>)
236 Takes an ident (i.e. a user-host-pair, e.g. I<user@host.domain.com> or
237 I<login@123.123.123.123>) and "unsharps it". The unsharp version is then
240 What unsharp exactly does is described in the F<README>.
254 print STDERR $/, __FILE__, ": Unsharp ``$ident''" if ($::DEBUG & 0x100);
256 ($user, $host) = split (m/@/, $ident, 2);
258 @parts = split (m/\./, $host);
259 $num_parts = scalar (@parts);
261 if (($UNSHARP ne 'NONE')
262 and ($user =~ m/^[\~\^\-\+\=](.+)$/))
267 if ($UNSHARP eq 'NONE')
269 return ($user, $host);
271 elsif ($host =~ m/^[\d\.]{7,15}$/)
273 if ($UNSHARP ne 'LIGHT')
280 for ($i = 0; $i < ($num_parts - 2); $i++)
282 if ($UNSHARP eq 'LIGHT')
284 if ($parts[$i] !~ s/\d+/*/g)
289 elsif ($UNSHARP eq 'MEDIUM')
291 if ($parts[$i] =~ m/\d/)
300 else # ($UNSHARP eq 'HARD')
307 $host = lc (join ('.', @parts));
308 $host =~ s/\*(?:\.\*)+/*/;
310 print STDERR " -> ``$user\@$host''" if ($::DEBUG & 0x100);
311 return ($user, $host);
314 =item B<calculate_nicks> ()
316 Iterates over all chatters found so far, trying to figure out which belong to
317 the same person. This function has to be called before any calls to
318 B<get_all_nicks>, B<get_main_nick>, B<get_print_name> and B<nick_to_ident>.
320 This is normally the step after having parsed all files and before doing any
321 output. After this function has been run all the other informative functions
322 return actually usefull information..
324 It does the following: First, it iterates over all chatters and splits them up
325 into nicks and idents. If a (user)name is found for the ident it (the ident) is
326 replaced with it (the name).
328 In the second step we iterate over all nicks that have been found and
329 determines the most active ident for each nick. After this has been done each
330 nick is associated with exactly one ident, but B<not> vice versa.
332 The final step is to iterate over all idents and determine the most active nick
333 for each ident. After some thought you will agree that now each ident exists
334 only once and so does every nick.
345 for ($ChatterList->keys ())
348 my ($nick, $ident) = split (m/!/, $chatter);
349 my $name = ident_to_name ($ident);
350 my ($counter) = $ChatterList->get ($chatter);
352 $nicks->{$nick}{$temp} = 0 unless (defined ($nicks->{$nick}{$temp}));
353 $nicks->{$nick}{$temp} += $counter;
359 my $this_ident = 'unidentified';
364 for (keys %{$nicks->{$this_nick}})
367 my $name = ident_to_name ($ident);
368 my $num = $nicks->{$this_nick}{$ident};
374 if (($num >= $this_max) or !$this_name)
377 $this_ident = $ident;
383 if (($num >= $this_max) and !$this_name)
386 $this_ident = $ident;
391 print $/, __FILE__, ": max_ident ($this_nick) = $this_ident" if ($::DEBUG & 0x100);
393 if ($this_ident ne 'unidentified')
397 $name2nick->{$this_name}{$this_nick} = 0 unless (defined ($names->{$this_name}{$this_nick}));
398 $name2nick->{$this_name}{$this_nick} += $this_total;
400 $name2ident->{$this_name}{$this_ident} = 0 unless (defined ($names->{$this_name}{$this_ident}));
401 $name2ident->{$this_name}{$this_ident} += $this_total;
405 $idents->{$this_ident}{$this_nick} = 0 unless (defined ($idents->{$this_ident}{$this_nick}));
406 $idents->{$this_ident}{$this_nick} += $this_total;
409 elsif ($::DEBUG & 0x100)
411 print STDERR $/, __FILE__, ": Ignoring unidentified nick ``$this_nick''";
420 my @other_nicks = ();
422 my @nicks = keys (%{$idents->{$this_ident}});
427 my $num = $idents->{$this_ident}{$nick};
429 if ($num > $this_max)
431 if ($this_nick) { push (@other_nicks, $this_nick); }
437 push (@other_nicks, $nick);
441 print STDERR $/, __FILE__, ": max_nick ($this_ident) = $this_nick" if ($::DEBUG & 0x100);
443 for (@other_nicks, $this_nick)
445 push (@AllNicks, $_);
446 $NickToNick{$_} = $this_nick;
447 $NickToIdent{$_} = $this_ident;
450 $IdentToNick{$this_ident} = $this_nick;
453 for (keys %$name2nick)
460 my @other_nicks = ();
461 my @other_idents = ();
463 for (keys %{$name2nick->{$name}})
466 my $num = $name2nick->{$name}{$nick};
470 push (@other_nicks, $max_nick) if ($max_nick);
476 push (@other_nicks, $nick);
481 for (keys %{$name2ident->{$name}})
484 my $num = $name2ident->{$name}{$ident};
488 push (@other_idents, $max_ident) if ($max_ident);
494 push (@other_idents, $ident);
498 for (@other_nicks, $max_nick)
500 push (@AllNicks, $_);
501 $NickToNick{$_} = $max_nick;
502 $NickToIdent{$_} = $max_ident;
505 for (@other_idents, $max_ident)
507 $IdentToNick{$_} = $max_nick;
512 =item I<@nicks> = B<get_all_nicks> ()
514 Returns an array of all seen nicks.
523 =item I<$channel> = B<get_channel> ()
525 Returns the name of the channel we're generating stats for.
531 my $chan = '#unknown'
533 if (get_config ('channel'))
535 $chan = get_config ('channel');
540 for ($ChannelNames->keys ())
543 my ($num) = $ChannelNames->get ($c);
544 if (defined ($num) and ($num > $max))
552 # Fix network-safe channel named (RFC 2811)
553 if ($chan =~ m/^![A-Z0-9]{5}.+/)
555 $chan =~ s/[A-Z0-9]{5}//;
561 =item I<$main> = B<get_main_nick> (I<$nick>)
563 Returns the main nick for I<$nick> or an empty string if the nick is unknown..
570 if (defined ($NickToNick{$nick}))
572 return ($NickToNick{$nick});
580 =item I<$ident> = B<nick_to_ident> (I<$nick>)
582 Returns the ident for this nick or an empty string if unknown. Before
583 B<calculate_nicks> is run it will use the database to find the most recent
584 mapping. After B<calculate_nicks> is run the calculated mapping will be used.
595 if (defined ($NickToIdent{$nick}))
597 $ident = $NickToIdent{$nick};
602 ($ident) = $Nick2Ident->get ($nick);
609 =item I<$nick> = B<ident_to_nick> (I<$ident>)
611 Returns the nick for the given ident or an empty string if unknown.
619 if (defined ($IdentToNick{$ident}))
621 return ($IdentToNick{$ident});
629 =item I<$lines> = B<get_total_lines> ()
631 Returns the total number of lines parsed so far.
637 return ($DATA->{'total_lines'});
640 =item B<nick_rename> (I<$old_nick>, I<$new_nick>)
642 Keeps track of a nick's hostname if the nick changes.
648 my $old_nick = shift;
649 my $new_nick = shift;
652 ($ident) = $Nick2Ident->get ($old_nick);
654 if (defined ($ident) and ($ident))
656 $Nick2Ident->put ($new_nick, $ident);
660 =item B<print_output> ()
662 Print the output. Should be called only once..
668 if (!$DATA->{'total_lines'})
670 print STDERR <<'MESSAGE';
674 The most common reasons for this are:
675 - The logfile used was empty.
676 - The ``logtype'' setting did not match the logfile.
677 - The logfile did not include a date.
691 delete ($DATA->{'byname'});
694 =item I<$data> = B<register_plugin> (I<$type>, I<$sub_ref>)
696 Register a subroutine for the given type. Returns a reference to the internal
697 data object. This will change soon, don't use it anymore if possible.
707 if (ref ($sub_ref) ne "CODE")
709 print STDERR $/, __FILE__, ": Plugin tried to register a non-code reference. Ignoring it.";
713 if ($type eq 'OUTPUT')
715 push (@$OUTPUT, $sub_ref);
719 if (!defined ($PluginCallbacks->{$type}))
721 $PluginCallbacks->{$type} = [];
725 push (@{$PluginCallbacks->{$type}}, $sub_ref);
727 print STDERR $/, __FILE__, ': ', scalar (caller ()), " registered for ``$type''." if ($::DEBUG & 0x800);
730 =item B<merge_idents> ()
732 Merges idents. Does magic, don't interfere ;)
738 my @idents = keys (%IdentToNick);
743 my $name = ident_to_name ($ident);
745 if (!defined ($DATA->{'byident'}{$ident}))
750 if (!defined ($DATA->{'byname'}{$name}))
752 $DATA->{'byname'}{$name} = {};
755 add_hash ($DATA->{'byname'}{$name}, $DATA->{'byident'}{$ident});
764 my @keys = keys (%$src);
769 my $val = $src->{$key};
771 if (!defined ($dst->{$key}))
780 print STDERR $/, __FILE__, ": ``$key'' = ``$val''" if ($::DEBUG);
784 $dst->{$key} += $val;
787 elsif (ref ($val) ne ref ($dst->{$key}))
789 print STDERR $/, __FILE__, ": Destination and source type do not match!" if ($::DEBUG);
791 elsif (ref ($val) eq "HASH")
793 add_hash ($dst->{$key}, $val);
795 elsif (ref ($val) eq "ARRAY")
804 print STDERR $/, __FILE__, ": ``", $key, '[', $i, "]'' = ``$j''" if ($::DEBUG);
808 $dst->{$key}->[$i] += $j;
815 my $type = ref ($val);
816 print STDERR $/, __FILE__, ": Reference type ``$type'' is not supported!", $/;
825 Florian octo Forster E<lt>octo at verplant.orgE<gt>