lib/Onis/Data/Core.pm

   1 package Onis::Data::Core;
   2
   3 =head1 NAME
   4
   5 Onis::Data::Core - User management
   6
   7 =head1 DESCRIPTION
   8
   9 Store data to the internal structure, care about users, nicks and idents and
  10 dispatch to plugins. The core of the data even..
  11
  12 =cut
  13
  14 use strict;
  15 use warnings;
  16
  17 use Exporter;
  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);
  22
  23 =head1 NAMING CONVENTION
  24
  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>.
  27
  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.
  31
  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>.
  34
  35 =cut
  36
  37 our $GeneralCounters  = Onis::Data::Persistent->new ('GeneralCounters', 'key', 'value');
  38 our $NickToIdentCache = Onis::Data::Persistent->new ('NickToIdentCache', 'nick', 'ident');
  39 our $ChatterList  = Onis::Data::Persistent->new ('ChatterList', 'chatter', 'counter');
  40 our $ChannelNames = Onis::Data::Persistent->new ('ChannelNames', 'channel', 'counter');
  41
  42 @Onis::Data::Core::EXPORT_OK =
  43 qw(
  44         store unsharp calculate_nicks
  45
  46         get_all_nicks get_channel get_main_nick nick_to_ident ident_to_nick nick_to_name
  47         get_total_lines get_most_recent_time nick_rename print_output register_plugin
  48 );
  49 @Onis::Data::Core::ISA = ('Exporter');
  50
  51 our $LinesThisRun = 0;
  52
  53 our $PluginCallbacks = {};
  54 our $OutputCallbacks = [];
  55 our @AllNicks = ();
  56
  57 our %NickToNick = ();
  58 our %NickToIdent = ();
  59 our %IdentToNick = ();
  60
  61 =head1 CONFIGURATION OPTIONS
  62
  63 =over 4
  64
  65 =item B<unsharp>: I<medium>;
  66
  67 Sets the amount of unsharping onis should do. Valid options are I<none>,
  68 I<light>, I<medium> and I<hard>.
  69
  70 =over 4
  71
  72 =item I<none>
  73
  74 does not do any unsharping.
  75
  76 =item I<light>
  77
  78 Leaves IP-addresses as they are. The deepest subdomains containing numbers have
  79 those numbers removed. So C<dsl-084-056-107-131.arcor-ip.net> becomes
  80 C<dsl-*-*-*-*.arcor-ip.net>.
  81
  82 =item I<medium>
  83
  84 Removes the last byte from IP-adresses. So C<84.56.107.131> becomes
  85 C<84.56.107.*>. Hostnames have the deepest subdomains removed if they contain
  86 numers, so C<dsl-084-056-107-131.arcor-ip.net> becomes C<*.arcor-ip.net> while
  87 C<shell.franken.de> is not modified. This is the default and recommended
  88 behavior.
  89
  90 =item I<hard>
  91
  92 Handles IP-addresses as I<medium>. Hostnames have all subdomains removed, so
  93 C<p5493EC60.dip.t-dialin.net> becomes C<*.t-dialin.net> and C<shell.franken.de>
  94 becomes C<*.franken.de>.
  95
  96 =back
  97
  98 =cut
  99
 100 our $UNSHARP = 'MEDIUM';
 101 if (get_config ('unsharp'))
 102 {
 103         my $tmp = get_config ('unsharp');
 104         $tmp = uc ($tmp);
 105         $tmp =~ s/\W//g;
 106
 107         if ($tmp eq 'NONE' or $tmp eq 'LIGHT'
 108                         or $tmp eq 'MEDIUM'
 109                         or $tmp eq 'HARD')
 110         {
 111                 $UNSHARP = $tmp;
 112         }
 113         else
 114         {
 115                 print STDERR $/, __FILE__, ": ``$tmp'' is not a valid value for config option ``unsharp''.",
 116                 $/, __FILE__, ": Using standard value ``MEDIUM''.";
 117         }
 118 }
 119
 120 =item B<channel>: I<name>;
 121
 122 Sets the name of the channel. This is mostly automatically figured out, use
 123 this if onis doesn't get it right or you want another name..
 124
 125 =back
 126
 127 =cut
 128
 129 # TODO
 130 # - lastrun
 131
 132 my $VERSION = '$Id$';
 133 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
 134
 135 return (1);
 136
 137 =head1 EXPORTED FUNCTIONS
 138
 139 =over 4
 140
 141 =item B<store> (I<$type>, I<$data>)
 142
 143 Passes I<$data> (a hashref) to all plugins which registered for I<$type>. This
 144 is the actual workhorse when parsing the file since it will be called once for
 145 every line found.
 146
 147 It will fill I<$data> with I<host>, I<user> and I<ident> if these fields are
 148 missing but have been seen for this nick before.
 149
 150 =cut
 151
 152 sub store
 153 {
 154         my $data = shift;
 155         my $type = $data->{'type'};
 156         my ($nick, $user, $host);
 157         my $ident;
 158
 159         if (!defined ($type))
 160         {
 161                 print STDERR $/, __FILE__, ": Plugin data did not include a type. This line will be skipped." if ($::DEBUG & 0x20);
 162                 return (undef);
 163         }
 164
 165         if (!defined ($data->{'nick'}))
 166         {
 167                 print STDERR $/, __FILE__, ": Plugin data did not include a nick. This line will be skipped." if ($::DEBUG & 0x20);
 168                 return (undef);
 169         }
 170
 171         $nick = $data->{'nick'};
 172
 173         if (defined ($data->{'host'}))
 174         {
 175                 my $chatter;
 176                 my $counter;
 177
 178                 ($user, $host) = unsharp ($data->{'host'});
 179                 $ident = "$user\@$host";
 180
 181                 $data->{'host'} = $host;
 182                 $data->{'user'} = $user;
 183                 $data->{'ident'} = $ident;
 184
 185                 $NickToIdentCache->put ($nick, $ident);
 186
 187                 $chatter = "$nick!$ident";
 188                 ($counter) = $ChatterList->get ($chatter);
 189                 $counter ||= 0; $counter++;
 190                 $ChatterList->put ($chatter, $counter);
 191         }
 192         elsif (($ident) = $NickToIdentCache->get ($nick))
 193         {
 194                 my $chatter = "$nick!$ident";
 195                 my $counter;
 196                 ($user, $host) = split (m/@/, $ident);
 197
 198                 $data->{'host'} = $host;
 199                 $data->{'user'} = $user;
 200                 $data->{'ident'} = $ident;
 201
 202                 ($counter) = $ChatterList->get ($chatter);
 203                 $counter ||= 0; $counter++;
 204                 $ChatterList->put ($chatter, $counter);
 205         }
 206         else
 207         {
 208                 $data->{'host'}  = $host  = '';
 209                 $data->{'user'}  = $user  = '';
 210                 $data->{'ident'} = $ident = '';
 211         }
 212
 213         if ($::DEBUG & 0x0100)
 214         {
 215                 print STDERR $/, __FILE__, ": id ($nick) = ", $ident;
 216         }
 217
 218         if (defined ($data->{'channel'}))
 219         {
 220                 my $chan = lc ($data->{'channel'});
 221                 my ($count) = $ChannelNames->get ($chan);
 222                 $count ||= 0; $count++;
 223                 $ChannelNames->put ($chan, $count);
 224         }
 225
 226         if (!defined ($data->{'epoch'}))
 227         {
 228                 $data->{'epoch'} = get_absolute_time ();
 229         }
 230
 231         if ($::DEBUG & 0x400)
 232         {
 233                 my @keys = keys (%$data);
 234                 for (sort (@keys))
 235                 {
 236                         my $key = $_;
 237                         my $val = $data->{$key};
 238                         print STDERR $/, __FILE__, ': ';
 239                         printf STDERR ("%10s: %s", $key, $val);
 240                 }
 241         }
 242
 243         {
 244                 my ($counter) = $GeneralCounters->get ('lines_total');
 245                 $counter ||= 0;
 246                 $counter++;
 247                 $GeneralCounters->put ('lines_total', $counter);
 248
 249                 my ($time) = $GeneralCounters->get ('most_recent_time');
 250                 $time ||= 0;
 251                 $time = $data->{'epoch'} if ($time < $data->{'epoch'});
 252                 $GeneralCounters->put ('most_recent_time', $time);
 253
 254                 $LinesThisRun++;
 255         }
 256
 257         if (defined ($PluginCallbacks->{$type}))
 258         {
 259                 for (@{$PluginCallbacks->{$type}})
 260                 {
 261                         $_->($data);
 262                 }
 263         }
 264
 265         return (1);
 266 }
 267
 268 =item (I<$user>, I<$host>) = B<unsharp> (I<$ident>)
 269
 270 Takes an ident (i.e. a user-host-pair, e.g. I<user@host.domain.com> or
 271 I<login@123.123.123.123>) and "unsharps it". The unsharp version is then
 272 returned.
 273
 274 =cut
 275
 276 sub unsharp
 277 {
 278         my $ident = shift;
 279
 280         my $user;
 281         my $host;
 282         my @parts;
 283         my $num_parts;
 284         my $i;
 285
 286         print STDERR $/, __FILE__, ": Unsharp ``$ident''" if ($::DEBUG & 0x100);
 287
 288         ($user, $host) = split (m/@/, $ident, 2);
 289
 290         @parts = split (m/\./, $host);
 291         $num_parts = scalar (@parts);
 292
 293         if (($UNSHARP ne 'NONE')
 294                         and ($user =~ m/^[\~\^\-\+\=](.+)$/))
 295         {
 296                 $user = $1;
 297         }
 298
 299         if ($UNSHARP eq 'NONE')
 300         {
 301                 return ($user, $host);
 302         }
 303         elsif ($host =~ m/^[\d\.]{7,15}$/)
 304         {
 305                 if ($UNSHARP ne 'LIGHT')
 306                 {
 307                         $parts[-1] = '*';
 308                 }
 309         }
 310         else
 311         {
 312                 for ($i = 0; $i < ($num_parts - 2); $i++)
 313                 {
 314                         if ($UNSHARP eq 'LIGHT')
 315                         {
 316                                 if ($parts[$i] !~ s/\d+/*/g)
 317                                 {
 318                                         last;
 319                                 }
 320                         }
 321                         elsif ($UNSHARP eq 'MEDIUM')
 322                         {
 323                                 if ($parts[$i] =~ m/\d/)
 324                                 {
 325                                         $parts[$i] = '*';
 326                                 }
 327                                 else
 328                                 {
 329                                         last;
 330                                 }
 331                         }
 332                         else # ($UNSHARP eq 'HARD')
 333                         {
 334                                 $parts[$i] = '*';
 335                         }
 336                 }
 337         }
 338
 339         $host = lc (join ('.', @parts));
 340         $host =~ s/\*(?:\.\*)+/*/;
 341
 342         print STDERR " -> ``$user\@$host''" if ($::DEBUG & 0x100);
 343         return ($user, $host);
 344 }
 345
 346 =item B<calculate_nicks> ()
 347
 348 Iterates over all chatters found so far, trying to figure out which belong to
 349 the same person. This function has to be called before any calls to
 350 B<get_all_nicks>, B<get_main_nick>, B<get_print_name> and B<nick_to_ident>.
 351
 352 This is normally the step after having parsed all files and before doing any
 353 output. After this function has been run all the other informative functions
 354 return actually usefull information..
 355
 356 It does the following: First, it iterates over all chatters and splits them up
 357 into nicks and idents. If a (user)name is found for the ident it (the ident) is
 358 replaced with it (the name).
 359
 360 In the second step we iterate over all nicks that have been found and
 361 determines the most active ident for each nick. After this has been done each
 362 nick is associated with exactly one ident, but B<not> vice versa.
 363
 364 The final step is to iterate over all idents and determine the most active nick
 365 for each ident. After some thought you will agree that now each ident exists
 366 only once and so does every nick.
 367
 368 =cut
 369
 370 sub calculate_nicks
 371 {
 372         my $nicks      = {};
 373         my $idents     = {};
 374         my $name2nick  = {};
 375         my $name2ident = {};
 376
 377         for ($ChatterList->keys ())
 378         {
 379                 my $chatter = $_;
 380                 my ($nick, $ident) = split (m/!/, $chatter);
 381                 my $name = ident_to_name ($ident);
 382                 my ($counter) = $ChatterList->get ($chatter);
 383
 384                 $nicks->{$nick}{$ident} = 0 unless (defined ($nicks->{$nick}{$ident}));
 385                 $nicks->{$nick}{$ident} += $counter;
 386         }
 387
 388         for (keys %$nicks)
 389         {
 390                 my $this_nick = $_;
 391                 my $this_ident = 'unidentified';
 392                 my $this_name = '';
 393                 my $this_total = 0;
 394                 my $this_max = 0;
 395
 396                 for (keys %{$nicks->{$this_nick}})
 397                 {
 398                         my $ident = $_;
 399                         my $name = ident_to_name ($ident);
 400                         my $num = $nicks->{$this_nick}{$ident};
 401
 402                         $this_total += $num;
 403
 404                         if ($name)
 405                         {
 406                                 if (($num >= $this_max) or !$this_name)
 407                                 {
 408                                         $this_max = $num;
 409                                         $this_ident = $ident;
 410                                         $this_name = $name;
 411                                 }
 412                         }
 413                         else
 414                         {
 415                                 if (($num >= $this_max) and !$this_name)
 416                                 {
 417                                         $this_max = $num;
 418                                         $this_ident = $ident;
 419                                 }
 420                         }
 421                 }
 422
 423                 print $/, __FILE__, ": max_ident ($this_nick) = $this_ident" if ($::DEBUG & 0x100);
 424
 425                 if ($this_ident ne 'unidentified')
 426                 {
 427                         if ($this_name)
 428                         {
 429                                 $name2nick->{$this_name}{$this_nick} = 0 unless (defined ($name2nick->{$this_name}{$this_nick}));
 430                                 $name2nick->{$this_name}{$this_nick} += $this_total;
 431
 432                                 $name2ident->{$this_name}{$this_ident} = 0 unless (defined ($name2nick->{$this_name}{$this_ident}));
 433                                 $name2ident->{$this_name}{$this_ident} += $this_total;
 434                         }
 435                         else
 436                         {
 437                                 $idents->{$this_ident}{$this_nick} = 0 unless (defined ($idents->{$this_ident}{$this_nick}));
 438                                 $idents->{$this_ident}{$this_nick} += $this_total;
 439                         }
 440                 }
 441                 elsif ($::DEBUG & 0x100)
 442                 {
 443                         print STDERR $/, __FILE__, ": Ignoring unidentified nick ``$this_nick''";
 444                 }
 445         }
 446
 447         for (keys %$idents)
 448         {
 449                 my $this_ident = $_;
 450                 my $this_nick = '';
 451                 my $this_max = 0;
 452                 my @other_nicks = ();
 453
 454                 my @nicks = keys (%{$idents->{$this_ident}});
 455
 456                 for (@nicks)
 457                 {
 458                         my $nick = $_;
 459                         my $num = $idents->{$this_ident}{$nick};
 460
 461                         if ($num > $this_max)
 462                         {
 463                                 if ($this_nick) { push (@other_nicks, $this_nick); }
 464                                 $this_nick = $nick;
 465                                 $this_max = $num;
 466                         }
 467                         else
 468                         {
 469                                 push (@other_nicks, $nick);
 470                         }
 471                 }
 472
 473                 print STDERR $/, __FILE__, ": max_nick ($this_ident) = $this_nick" if ($::DEBUG & 0x100);
 474
 475                 for (@other_nicks, $this_nick)
 476                 {
 477                         push (@AllNicks, $_);
 478                         $NickToNick{$_} = $this_nick;
 479                         $NickToIdent{$_} = $this_ident;
 480                 }
 481
 482                 $IdentToNick{$this_ident} = $this_nick;
 483         }
 484
 485         for (keys %$name2nick)
 486         {
 487                 my $name = $_;
 488                 my $max_num = 0;
 489                 my $max_nick = '';
 490                 my $max_ident = '';
 491
 492                 my @other_nicks = ();
 493                 my @other_idents = ();
 494
 495                 for (keys %{$name2nick->{$name}})
 496                 {
 497                         my $nick = $_;
 498                         my $num = $name2nick->{$name}{$nick};
 499
 500                         if ($num > $max_num)
 501                         {
 502                                 push (@other_nicks, $max_nick) if ($max_nick);
 503                                 $max_nick = $nick;
 504                                 $max_num  = $num;
 505                         }
 506                         else
 507                         {
 508                                 push (@other_nicks, $nick);
 509                         }
 510                 }
 511
 512                 $max_num = 0;
 513                 for (keys %{$name2ident->{$name}})
 514                 {
 515                         my $ident = $_;
 516                         my $num = $name2ident->{$name}{$ident};
 517
 518                         if ($num > $max_num)
 519                         {
 520                                 push (@other_idents, $max_ident) if ($max_ident);
 521                                 $max_ident = $ident;
 522                                 $max_num  = $num;
 523                         }
 524                         else
 525                         {
 526                                 push (@other_idents, $ident);
 527                         }
 528                 }
 529
 530                 for (@other_nicks, $max_nick)
 531                 {
 532                         push (@AllNicks, $_);
 533                         $NickToNick{$_} = $max_nick;
 534                         $NickToIdent{$_} = $max_ident;
 535                 }
 536
 537                 for (@other_idents, $max_ident)
 538                 {
 539                         $IdentToNick{$_} = $max_nick;
 540                 }
 541         }
 542 }
 543
 544 =item I<@nicks> = B<get_all_nicks> ()
 545
 546 Returns an array of all seen nicks.
 547
 548 =cut
 549
 550 sub get_all_nicks
 551 {
 552         return (@AllNicks);
 553 }
 554
 555 =item I<$channel> = B<get_channel> ()
 556
 557 Returns the name of the channel we're generating stats for.
 558
 559 =cut
 560
 561 sub get_channel
 562 {
 563         my $chan = '#unknown';
 564         if (get_config ('channel'))
 565         {
 566                 $chan = get_config ('channel');
 567         }
 568         else
 569         {
 570                 my $max = 0;
 571                 for ($ChannelNames->keys ())
 572                 {
 573                         my $c = $_;
 574                         my ($num) = $ChannelNames->get ($c);
 575                         if (defined ($num) and ($num > $max))
 576                         {
 577                                 $max = $num;
 578                                 $chan = $c;
 579                         }
 580                 }
 581         }
 582
 583         # Fix network-safe channel named (RFC 2811)
 584         if ($chan =~ m/^![A-Z0-9]{5}(.+)/)
 585         {
 586                 $chan = '!' . $1;
 587         }
 588
 589         return ($chan);
 590 }
 591
 592 =item I<$main> = B<get_main_nick> (I<$nick>)
 593
 594 Returns the main nick for I<$nick> or an empty string if the nick is unknown..
 595
 596 =cut
 597
 598 sub get_main_nick
 599 {
 600         my $nick = shift;
 601         if (defined ($NickToNick{$nick}))
 602         {
 603                 return ($NickToNick{$nick});
 604         }
 605         else
 606         {
 607                 return ('');
 608         }
 609 }
 610
 611 =item I<$ident> = B<nick_to_ident> (I<$nick>)
 612
 613 Returns the ident for this nick or an empty string if unknown. Before
 614 B<calculate_nicks> is run it will use the database to find the most recent
 615 mapping. After B<calculate_nicks> is run the calculated mapping will be used.
 616
 617 =cut
 618
 619 sub nick_to_ident
 620 {
 621         my $nick = shift;
 622         my $ident = '';
 623
 624         if (%NickToIdent)
 625         {
 626                 if (defined ($NickToIdent{$nick}))
 627                 {
 628                         $ident = $NickToIdent{$nick};
 629                 }
 630         }
 631         else
 632         {
 633                 ($ident) = $NickToIdentCache->get ($nick);
 634                 $ident ||= '';
 635         }
 636
 637         return ($ident);
 638 }
 639
 640 =item I<$nick> = B<ident_to_nick> (I<$ident>)
 641
 642 Returns the nick for the given ident or an empty string if unknown.
 643
 644 =cut
 645
 646 sub ident_to_nick
 647 {
 648         my $ident = shift;
 649
 650         if (defined ($IdentToNick{$ident}))
 651         {
 652                 return ($IdentToNick{$ident});
 653         }
 654         else
 655         {
 656                 return ('');
 657         }
 658 }
 659
 660 =item I<$name> = B<nick_to_name> (I<$nick>)
 661
 662 Return the name associated with I<$nick>. This function uses B<ident_to_name>
 663 (see L<Onis::Users>).
 664
 665 =cut
 666
 667 sub nick_to_name
 668 {
 669         my $nick = shift;
 670         my $ident = nick_to_ident ($nick);
 671
 672         if ($ident)
 673         {
 674                 return (ident_to_name ($ident));
 675         }
 676         else
 677         {
 678                 return ('');
 679         }
 680 }
 681
 682 =item I<$lines> = B<get_total_lines> ()
 683
 684 Returns the total number of lines parsed so far.
 685
 686 =cut
 687
 688 sub get_total_lines
 689 {
 690         my ($total) = $GeneralCounters->get ('lines_total');
 691
 692         return (qw()) unless ($total);
 693
 694         return ($total, $LinesThisRun);
 695 }
 696
 697 =item I<$epoch> = B<get_most_recent_time> ()
 698
 699 Returns the epoch of the most recent line received from the parser.
 700
 701 =cut
 702
 703 sub get_most_recent_time
 704 {
 705         my ($time) = $GeneralCounters->get ('most_recent_time');
 706         $time ||= 0;
 707
 708         return ($time);
 709 }
 710
 711 =item B<nick_rename> (I<$old_nick>, I<$new_nick>)
 712
 713 Keeps track of a nick's hostname if the nick changes.
 714
 715 =cut
 716
 717 sub nick_rename
 718 {
 719         my $old_nick = shift;
 720         my $new_nick = shift;
 721         my $ident;
 722
 723         ($ident) = $NickToIdentCache->get ($old_nick);
 724
 725         if (defined ($ident) and ($ident))
 726         {
 727                 $NickToIdentCache->put ($new_nick, $ident);
 728         }
 729 }
 730
 731 =item B<print_output> ()
 732
 733 Print the output. Should be called only once..
 734
 735 =cut
 736
 737 sub print_output
 738 {
 739         # FIXME FIXME FIXME
 740         if (!get_total_lines ())
 741         {
 742                 print STDERR <<'MESSAGE';
 743
 744 ERROR: No data found
 745
 746 The most common reasons for this are:
 747 - The logfile used was empty.
 748 - The ``logtype'' setting did not match the logfile.
 749 - The logfile did not include a date.
 750
 751 MESSAGE
 752                 return;
 753         }
 754
 755         calculate_nicks ();
 756
 757         for (@$OutputCallbacks)
 758         {
 759                 &$_ ();
 760         }
 761 }
 762
 763 =item I<$data> = B<register_plugin> (I<$type>, I<$sub_ref>)
 764
 765 Register a subroutine for the given type. Returns a reference to the internal
 766 data object. This will change soon, don't use it anymore if possible.
 767
 768 =cut
 769
 770 sub register_plugin
 771 {
 772         my $type = shift;
 773         my $sub_ref = shift;
 774
 775         $type = uc ($type);
 776         if (ref ($sub_ref) ne "CODE")
 777         {
 778                 print STDERR $/, __FILE__, ": Plugin tried to register a non-code reference. Ignoring it.";
 779                 return (undef);
 780         }
 781
 782         if ($type eq 'OUTPUT')
 783         {
 784                 push (@$OutputCallbacks, $sub_ref);
 785         }
 786         else
 787         {
 788                 if (!defined ($PluginCallbacks->{$type}))
 789                 {
 790                         $PluginCallbacks->{$type} = [];
 791                 }
 792         }
 793
 794         push (@{$PluginCallbacks->{$type}}, $sub_ref);
 795
 796         print STDERR $/, __FILE__, ': ', scalar (caller ()), " registered for ``$type''." if ($::DEBUG & 0x800);
 797 }
 798
 799 =back
 800
 801 =head1 AUTHOR
 802
 803 Florian octo Forster E<lt>octo at verplant.orgE<gt>
 804
 805 =cut