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