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