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