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