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#get_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 %IdentToNick = ();
  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<get_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                 next if (lc ($name) eq 'ignore');
 345
 346                 $nicks->{$nick}{$temp} = 0 unless (defined ($nicks->{$nick}{$temp}));
 347                 $nicks->{$nick}{$temp} += $counter;
 348         }
 349
 350         for (keys %$nicks)
 351         {
 352                 my $this_nick = $_;
 353                 my $this_ident = 'unidentified';
 354                 my $this_total = 0;
 355                 my $this_max = 0;
 356                 my $this_ident_is_user = 0;
 357
 358                 for (keys %{$nicks->{$this_nick}})
 359                 {
 360                         my $ident = $_;
 361                         my $num = $nicks->{$this_nick}{$ident};
 362
 363                         $this_total += $num;
 364
 365                         if ($ident =~ m/@/) # $ident is a (user)name
 366                         {
 367                                 if (($num >= $this_max) or !$this_ident_is_user)
 368                                 {
 369                                         $this_max = $num;
 370                                         $this_ident = $ident;
 371                                         $this_ident_is_user = 1;
 372                                 }
 373                         }
 374                         else
 375                         {
 376                                 if (($num >= $this_max) and !$this_ident_is_user)
 377                                 {
 378                                         $this_max = $num;
 379                                         $this_ident = $ident;
 380                                 }
 381                         }
 382                 }
 383
 384                 print $/, __FILE__, ": max_ident ($this_nick) = $this_ident" if ($::DEBUG & 0x100);
 385
 386                 if ($this_ident ne 'unidentified')
 387                 {
 388                         $idents->{$this_ident}{$this_nick} = 0 unless (defined ($idents->{$this_ident}{$this_nick}));
 389                         $idents->{$this_ident}{$this_nick} += $this_total;
 390                 }
 391                 elsif ($::DEBUG & 0x100)
 392                 {
 393                         print STDERR $/, __FILE__, ": Ignoring unidentified nick ``$this_nick''";
 394                 }
 395         }
 396
 397         for (keys %$idents)
 398         {
 399                 my $this_ident = $_;
 400                 my $this_nick = '';
 401                 my $this_max = 0;
 402                 my @other_nicks = ();
 403
 404                 my @nicks = keys (%{$idents->{$this_ident}});
 405
 406                 for (@nicks)
 407                 {
 408                         my $nick = $_;
 409                         my $num = $nicks_of_ident->{$this_ident}{$nick};
 410
 411                         if ($num > $this_max)
 412                         {
 413                                 if ($this_nick) { push (@other_nicks, $this_nick); }
 414                                 $this_nick = $nick;
 415                                 $this_max = $num;
 416                         }
 417                         else
 418                         {
 419                                 push (@other_nicks, $nick);
 420                         }
 421                 }
 422
 423                 print STDERR $/, __FILE__, ": max_nick ($this_ident) = $this_nick" if ($::DEBUG & 0x100);
 424
 425                 for (@other_nicks, $this_nick)
 426                 {
 427                         push (@AllNicks, $_);
 428                         $NickMap{$_} = $this_nick;
 429                         # FIXME
 430                         $NickToIdent{$_} = $this_ident;
 431                 }
 432
 433                 $IdentToNick{$this_ident} = $this_nick;
 434         }
 435 }
 436
 437 =item I<@nicks> = B<get_all_nicks> ()
 438
 439 Returns an array of all seen nicks.
 440
 441 =cut
 442
 443 sub get_all_nicks
 444 {
 445         return (@AllNicks);
 446 }
 447
 448 =item I<$channel> = B<get_channel> ()
 449
 450 Returns the name of the channel we're generating stats for.
 451
 452 =cut
 453
 454 sub get_channel
 455 {
 456         my $chan;
 457         if (get_config ('channel'))
 458         {
 459                 $chan = get_config ('channel');
 460         }
 461         elsif (keys (%{$DATA->{'channel'}}))
 462         {
 463                 ($chan) = sort
 464                 {
 465                         $DATA->{'channel'}{$b} <=> $DATA->{'channel'}{$a}
 466                 } (keys (%{$DATA->{'channel'}}));
 467         }
 468         else
 469         {
 470                 $chan = '#unknown';
 471         }
 472
 473         # Fix network-safe channel named (RFC 2811)
 474         if ($chan =~ m/^![A-Z0-9]{5}.+/)
 475         {
 476                 $chan =~ s/[A-Z0-9]{5}//;
 477         }
 478
 479         return ($chan);
 480 }
 481
 482 =item I<$main> = B<get_main_nick> (I<$nick>)
 483
 484 Returns the main nick for I<$nick> or an empty string if the nick is unknown..
 485
 486 =cut
 487
 488 sub get_main_nick
 489 {
 490         my $nick = shift;
 491         if (defined ($NickMap{$nick}))
 492         {
 493                 return ($NickMap{$nick});
 494         }
 495         else
 496         {
 497                 return ('');
 498         }
 499 }
 500
 501 =item I<$ident> = B<nick_to_ident> (I<$nick>)
 502
 503 Returns the ident for this nick or an empty string if unknown.
 504
 505 =cut
 506
 507 sub nick_to_ident
 508 {
 509         my $nick = shift;
 510
 511         my ($ident) = $Nick2Ident->get ($nick);
 512         $ident ||= '';
 513
 514         return ($ident);
 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 ($IdentToNick{$ident}))
 534         {
 535                 return ($IdentToNick{$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 (%IdentToNick);
 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