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