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