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#host_to_username nick_to_username#;
20 use Onis::Data::Persistent;
22 =head1 NAMING CONVENTION
24 Each and every person in the IRC can be identified by a three-tupel: B<nick>,
25 B<user> and B<host>, most often seen as I<nick!user@host>.
27 The combination of B<user> and B<host> is called an B<ident> here and written
28 I<user@host>. The combination of all three parts is called a B<chatter> here,
29 though it's rarely used.
31 A B<name> is the name of the "user" as defined in the F<users.conf>. Therefore,
32 the F<users.conf> defines a mapping of B<chatter> -E<gt> B<name>.
36 our $Nick2Ident = Onis::Data::Persistent->new ('Nick2Ident', 'nick', 'ident');
37 our $ChatterList = Onis::Data::Persistent->new ('ChatterList', 'chatter', 'counter');
38 our $ChannelNames = Onis::Data::Persistent->new ('ChannelNames', 'channel', 'counter');
42 @Onis::Data::Core::EXPORT_OK = qw#all_nicks get_channel
44 ident_to_nick ident_to_name
46 get_total_lines nick_rename print_output
47 register_plugin store get_print_name#;
48 @Onis::Data::Core::ISA = ('Exporter');
50 our $DATA = init ('$DATA', 'hash');
52 our $PluginCallbacks = {};
57 our %NickToIdent = ();
59 our $LASTRUN_DAYS = 0;
63 our $UNSHARP = 'MEDIUM';
64 if (get_config ('unsharp'))
66 my $tmp = get_config ('unsharp');
70 if ($tmp eq 'NONE' or $tmp eq 'LIGHT'
78 print STDERR $/, __FILE__, ": ``$tmp'' is not a valid value for config option ``unsharp''.",
79 $/, __FILE__, ": Using standard value ``MEDIUM''.";
85 $DATA->{'idents_of_nick'} = {};
86 $DATA->{'channel'} = {};
87 $DATA->{'total_lines'} = 0;
90 if (defined ($DATA->{'lastrun'}))
92 my $last = $DATA->{'lastrun'};
95 my $diff = ($now - $last) % 86400;
99 $DATA->{'lastrun'} = $now;
100 $LASTRUN_DAYS = $diff;
105 $DATA->{'lastrun'} = time;
108 my $VERSION = '$Id: Core.pm,v 1.14 2004/10/31 15:00:32 octo Exp $';
109 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
113 =head1 EXPORTED FUNCTIONS
117 =item B<store> (I<$type>, I<$data>)
119 Passes I<$data> (a hashref) to all plugins which registered for I<$type>. This
120 is the actual workhorse when parsing the file since it will be called once for
123 It will fill I<$data> with I<host>, I<user> and I<ident> if these fields are
124 missing but have been seen for this nick before.
131 my $type = $data->{'type'};
132 my ($nick, $user, $host);
135 if (!defined ($type))
137 print STDERR $/, __FILE__, ": Plugin data did not include a type. This line will be skipped." if ($::DEBUG & 0x20);
141 if (!defined ($data->{'nick'}))
143 print STDERR $/, __FILE__, ": Plugin data did not include a nick. This line will be skipped." if ($::DEBUG & 0x20);
147 $nick = $data->{'nick'};
149 if (defined ($data->{'host'}))
154 ($user, $host) = unsharp ($data->{'host'});
155 $ident = "$user\@$host";
157 $data->{'host'} = $host;
158 $data->{'user'} = $user;
159 $data->{'ident'} = $ident;
161 $Nick2Ident->put ($nick, $ident);
163 $chatter = "$nick!$ident";
164 ($counter) = $ChatterList->get ($chatter);
165 $counter ||= 0; $counter++;
166 $ChatterList->put ($chatter, $counter);
168 elsif (($ident) = $Nick2Ident->get ($nick))
170 my $chatter = "$nick!$ident";
171 ($user, $host) = split (m/@/, $ident);
173 $data->{'host'} = $host;
174 $data->{'user'} = $user;
175 $data->{'ident'} = $ident;
177 ($counter) = $ChatterList->get ($chatter);
178 $counter ||= 0; $counter++;
179 $ChatterList->put ($chatter, $counter);
183 $data->{'host'} = $host = '';
184 $data->{'user'} = $user = '';
185 $data->{'ident'} = $ident = '';
188 if ($::DEBUG & 0x0100)
190 print STDERR $/, __FILE__, ": id ($nick) = ", $ident;
193 if (defined ($data->{'channel'}))
195 my $chan = lc ($data->{'channel'});
196 my ($count) = $ChannelNames->get ($chan);
197 $count ||= 0; $count++;
198 $ChannelNames->put ($chan, $count);
201 if ($::DEBUG & 0x400)
203 my @keys = keys (%$data);
207 my $val = $data->{$key};
208 print STDERR $/, __FILE__, ': ';
209 printf STDERR ("%10s: %s", $key, $val);
213 #$DATA->{'total_lines'}++;
215 if (defined ($PluginCallbacks->{$type}))
217 for (@{$PluginCallbacks->{$type}})
226 =item (I<$user>, I<$host>) = B<unsharp> (I<$ident>)
228 Takes an ident (i.e. a user-host-pair, e.g. I<user@host.domain.com> or
229 I<login@123.123.123.123>) and "unsharps it". The unsharp version is then
232 What unsharp exactly does is described in the F<README>.
246 print STDERR $/, __FILE__, ": Unsharp ``$ident''" if ($::DEBUG & 0x100);
248 ($user, $host) = split (m/@/, $ident, 2);
250 @parts = split (m/\./, $host);
251 $num_parts = scalar (@parts);
253 if (($UNSHARP ne 'NONE')
254 and ($user =~ m/^[\~\^\-\+\=](.+)$/))
259 if ($UNSHARP eq 'NONE')
261 return ($user, $host);
263 elsif ($host =~ m/^[\d\.]{7,15}$/)
265 if ($UNSHARP ne 'LIGHT')
272 for ($i = 0; $i < ($num_parts - 2); $i++)
274 if ($UNSHARP eq 'LIGHT')
276 if ($parts[$i] !~ s/\d+/*/g)
281 elsif ($UNSHARP eq 'MEDIUM')
283 if ($parts[$i] =~ m/\d/)
292 else # ($UNSHARP eq 'HARD')
299 $host = lc (join ('.', @parts));
300 $host =~ s/\*(?:\.\*)+/*/;
302 print STDERR " -> ``$user\@$host''" if ($::DEBUG & 0x100);
303 return ($user, $host);
306 =item B<calculate_nicks> ()
308 Iterates over all chatters found so far, trying to figure out which belong to
309 the same person. This function has to be called before any calls to
310 B<all_nicks>, B<get_main_nick>, B<get_print_name> and B<nick_to_ident>.
312 This is normally the step after having parsed all files and before doing any
313 output. After this function has been run all the other informative functions
314 return actually usefull information..
316 It does the following: First, it iterates over all chatters and splits them up
317 into nicks and idents. If a (user)name is found for the ident it (the ident) is
318 replaced with it (the name).
320 In the second step we iterate over all nicks that have been found and
321 determines the most active ident for each nick. After this has been done each
322 nick is associated with exactly one ident, but B<not> vice versa.
324 The final step is to iterate over all idents and determine the most active nick
325 for each ident. After some thought you will agree that now each ident exists
326 only once and so does every nick.
335 for ($ChatterList->keys ())
338 my ($nick, $ident) = split (m/!/, $chatter);
339 my $name = host_to_username ($chatter);
340 my ($counter) = $ChatterList->get ($chatter);
342 my $temp = $name ? $name : $ident;
344 $nicks->{$nick}{$temp} = 0 unless (defined ($nicks->{$nick}{$temp}));
345 $nicks->{$nick}{$temp} += $counter;
351 my $this_ident = 'unidentified';
354 my $this_ident_is_user = 0;
356 for (keys %{$nicks->{$this_nick}})
359 my $num = $nicks->{$this_nick}{$ident};
363 if ($ident =~ m/@/) # $ident is a (user)name
365 if (($num >= $this_max) or !$this_ident_is_user)
368 $this_ident = $ident;
369 $this_ident_is_user = 1;
374 if (($num >= $this_max) and !$this_ident_is_user)
377 $this_ident = $ident;
382 print $/, __FILE__, ": max_ident ($this_nick) = $this_ident" if ($::DEBUG & 0x100);
384 if ($this_ident ne 'unidentified')
386 $idents->{$this_ident}{$this_nick} = 0 unless (defined ($idents->{$this_ident}{$this_nick}));
387 $idents->{$this_ident}{$this_nick} += $this_total;
389 elsif ($::DEBUG & 0x100)
391 print STDERR $/, __FILE__, ": Ignoring unidentified nick ``$this_nick''";
400 my @other_nicks = ();
402 my @nicks = keys (%{$idents->{$this_ident}});
407 my $num = $nicks_of_ident->{$this_ident}{$nick};
409 if ($num > $this_max)
411 if ($this_nick) { push (@other_nicks, $this_nick); }
417 push (@other_nicks, $nick);
421 print STDERR $/, __FILE__, ": max_nick ($this_ident) = $this_nick" if ($::DEBUG & 0x100);
423 for (@other_nicks, $this_nick)
425 push (@AllNicks, $_);
426 $NickMap{$_} = $this_nick;
427 $NickToIdent{$_} = $this_ident;
430 $IDENT2NICK{$this_ident} = $this_nick;
434 =item I<@nicks> = B<all_nicks> ()
436 Returns an array of all seen nicks.
445 =item I<$channel> = B<get_channel> ()
447 Returns the name of the channel we're generating stats for.
454 if (get_config ('channel'))
456 $chan = get_config ('channel');
458 elsif (keys (%{$DATA->{'channel'}}))
462 $DATA->{'channel'}{$b} <=> $DATA->{'channel'}{$a}
463 } (keys (%{$DATA->{'channel'}}));
470 # Fix network-safe channel named (RFC 2811)
471 if ($chan =~ m/^![A-Z0-9]{5}.+/)
473 $chan =~ s/[A-Z0-9]{5}//;
479 =item I<$main> = B<get_main_nick> (I<$nick>)
481 Returns the main nick for I<$nick> or an empty string if the nick is unknown..
488 if (defined ($NickMap{$nick}))
490 return ($NickMap{$nick});
498 =item I<$ident> = B<nick_to_ident> (I<$nick>)
500 Returns the ident for this nick or an empty string if unknown.
507 if (defined ($NickToIdent{$nick}))
509 return ($NickToIdent{$nick});
517 =item I<$nick> = B<ident_to_nick> (I<$ident>)
519 Returns the nick for the given ident or an empty string if unknown.
527 if (!defined ($ident)
528 or (lc ($ident) eq 'ignore')
529 or (lc ($ident) eq 'unidentified'))
533 elsif (defined ($IDENT2NICK{$ident}))
535 return ($IDENT2NICK{$ident});
543 =item I<$name> = B<ident_to_name> (I<$ident>)
545 Returns the printable version of the name for the chatter identified by
546 I<$ident>. Returns an empty string if the ident is not known.
553 my $nick = ident_to_nick ($ident);
561 $name = get_print_name ($nick);
566 =item I<$name> = B<get_print_name> (I<$nick>)
568 Returns the printable version of the name for the nick I<$nick> or I<$nick> if
579 if (defined ($NickToIdent{$nick}))
581 $ident = $NickToIdent{$nick};
584 if (($ident !~ m/^[^@]+@.+$/) and $ident)
592 =item I<$lines> = B<get_total_lines> ()
594 Returns the total number of lines parsed so far.
600 return ($DATA->{'total_lines'});
603 =item B<nick_rename> (I<$old_nick>, I<$new_nick>)
605 Keeps track of a nick's hostname if the nick changes.
611 my $old_nick = shift;
612 my $new_nick = shift;
614 if (defined ($DATA->{'host_cache'}{$old_nick}))
616 my $host = $DATA->{'host_cache'}{$old_nick};
617 $DATA->{'host_cache'}{$new_nick} = $host;
619 if (!defined ($DATA->{'hosts_of_nick'}{$new_nick}{$host}))
621 $DATA->{'hosts_of_nick'}{$new_nick}{$host} = 1;
625 if (defined ($DATA->{'byident'}{"$old_nick\@unidentified"}))
627 # Other data may be overwritten, but I don't care here..
628 # This should be a extremely rare case..
629 $DATA->{'byident'}{"$new_nick\@unidentified"} = $DATA->{'byident'}{"$old_nick\@unidentified"};
630 delete ($DATA->{'byident'}{"$old_nick\@unidentified"});
634 =item B<print_output> ()
636 Print the output. Should be called only once..
642 if (!$DATA->{'total_lines'})
644 print STDERR <<'MESSAGE';
648 The most common reasons for this are:
649 - The logfile used was empty.
650 - The ``logtype'' setting did not match the logfile.
651 - The logfile did not include a date.
665 delete ($DATA->{'byname'});
668 =item I<$data> = B<register_plugin> (I<$type>, I<$sub_ref>)
670 Register a subroutine for the given type. Returns a reference to the internal
671 data object. This will change soon, don't use it anymore if possible.
681 if (ref ($sub_ref) ne "CODE")
683 print STDERR $/, __FILE__, ": Plugin tried to register a non-code reference. Ignoring it.";
687 if ($type eq 'OUTPUT')
689 push (@$OUTPUT, $sub_ref);
693 if (!defined ($PluginCallbacks->{$type}))
695 $PluginCallbacks->{$type} = [];
699 push (@{$PluginCallbacks->{$type}}, $sub_ref);
701 print STDERR $/, __FILE__, ': ', scalar (caller ()), " registered for ``$type''." if ($::DEBUG & 0x800);
706 =item B<merge_idents> ()
708 Merges idents. Does magic, don't interfere ;)
714 my @idents = keys (%IDENT2NICK);
719 my $name = ident_to_name ($ident);
721 if (!defined ($DATA->{'byident'}{$ident}))
726 if (!defined ($DATA->{'byname'}{$name}))
728 $DATA->{'byname'}{$name} = {};
731 add_hash ($DATA->{'byname'}{$name}, $DATA->{'byident'}{$ident});
740 my @keys = keys (%$src);
745 my $val = $src->{$key};
747 if (!defined ($dst->{$key}))
756 print STDERR $/, __FILE__, ": ``$key'' = ``$val''" if ($::DEBUG);
760 $dst->{$key} += $val;
763 elsif (ref ($val) ne ref ($dst->{$key}))
765 print STDERR $/, __FILE__, ": Destination and source type do not match!" if ($::DEBUG);
767 elsif (ref ($val) eq "HASH")
769 add_hash ($dst->{$key}, $val);
771 elsif (ref ($val) eq "ARRAY")
780 print STDERR $/, __FILE__, ": ``", $key, '[', $i, "]'' = ``$j''" if ($::DEBUG);
784 $dst->{$key}->[$i] += $j;
791 my $type = ref ($val);
792 print STDERR $/, __FILE__, ": Reference type ``$type'' is not supported!", $/;
801 Florian octo Forster E<lt>octo at verplant.orgE<gt>