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