usestats.pl

   1 #!/usr/bin/perl
   2 #
   3 # usestats.pl
   4 #############
   5
   6 # (c) 10/2003-10/2004 Thomas Hochstein  <thh@inter.net>
   7 #
   8 # This program is free software; you can redistribute it and/or modify it under
   9 # the terms of the GNU General Public License as published by the Free
  10 # Software Foundation; either version 2 of the License, or (at your option)
  11 # any later version.
  12 # This program is distributed in the hope that it will be useful, but WITHOUT
  13 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
  15 # more details.
  16
  17 # Modules #############################
  18 # use Data::Dumper;
  19 use Date::Manip qw(Date_Init ParseDate Date_Cmp DateCalc UnixDate Delta_Format Date_DaysInMonth);
  20 use File::Find;
  21 use Getopt::Std;
  22 use Locale::Recode;
  23 use Mail::Address;
  24 use MIME::Words qw(decode_mimewords);
  25
  26 # Versionsnummer ######################
  27 $ver = '0.17 beta (20041003)';
  28
  29 # Konstanten  #########################
  30
  31 $hex_nibb     = '[0-9a-fA-F]';
  32 $gt_hex_nibb  = '[0-9A-F]';
  33 $lt_hex_nibb  = '[0-9a-f]';
  34 $alpha_num    = '[0-9a-zA-Z]';
  35 $lt_alpha_num = '[0-9a-z]';
  36 $gt_alpha_num = '[0-9A-Z]';
  37 %reporttitel = ('newsgroups' => 'Newsgroupnutzung',
  38                 'poster'     => 'Poster (strukturiert)',
  39                 'posterraw'  => 'Poster (unstrukturiert)',
  40                 'subject'    => 'Subjects (strukturiert)',
  41                 'newsreader' => 'Newsreader (strukturiert)',
  42                 'nruser'     => 'Nutzer pro Newsreader (strukturiert)');
  43
  44 # Variablen ###########################
  45
  46 # Defaults
  47 %config=();
  48
  49 # $config{'newsgroup'} = '';
  50 # $config{'start'} = '';
  51 # $config{'stop'}  = '';
  52 $config{'recursive'} = 0;
  53 $config{'pipeformat'} = 'mbox';
  54 $config{'charset'} = 'ISO-8859-1';
  55 $config{'tz'} = '+0200';
  56 $config{'graphchar'} = '#';
  57
  58 $config{'day'} = 1;
  59 @reports = ('newsgroups','poster','posterraw','subject','newsreader','nruser');
  60 foreach $report (@reports) {
  61  $config{$report} = 1;
  62  $config{$report.'_width'}  = 30;
  63  $config{$report.'_indent'} = 2;
  64  $config{$report.'_lines'}  = 0;
  65  $config{$report.'_cutoff'} = 0;
  66  $config{$report.'_graph'}  = 20;
  67 };
  68 $config{'newsgroups'} = 0;
  69 $config{'posterraw'} = 0;
  70 $config{'unknownreader'} = 'show';
  71
  72 # Hauptprogramm #######################
  73 # Konfiguration einlesen
  74 my %options;
  75 getopts('hqc:r:w:', \%options);
  76 if ($options{'h'}) {
  77  print "$0 v $ver\nUsage: $0 [-hq] [-w|r <savefile>] [-c <configfile>]\n";
  78  exit(0);
  79 };
  80 print STDERR "$0 v $ver [" . scalar(gmtime) . "]\n(c) 10/2003-10/2004 Thomas Hochstein * <thh\@inter.net>\n" if (!$options{'q'});
  81 if ($options{'c'}) {
  82   &readconfig($options{'c'});
  83 };
  84 if (length($config{'graphchar'}) > 1 or $config{'graphchar'} eq '') {
  85  $config{'graphchar'} = '#';
  86 };
  87 # Charset prüfen
  88 $config{'charset'} = uc($config{'charset'});
  89 $supported = Locale::Recode->getSupported;
  90 if (!scalar(grep /$config{'charset'}/, @{$supported})) {
  91  print STDERR "ERROR: unknown charset $config{'charset'}\n";
  92  $config{'charset'} = 'ISO-8859-1';
  93 };
  94
  95 &Date_Init("TZ = $config{'tz'}");
  96
  97 if ($options{'r'}) {
  98  @postings = @{&readdata($options{'r'})};
  99  print STDERR "\n>>>>> Data loaded.\n\n" if (!$options{'q'});
 100 } else {
 101  # Postings parsen
 102  if (exists($config{'spooldir'})) {
 103   if ($config{'recursive'}) {
 104    @postings = @{&get_spool_recursive($config{'spooldir'})};
 105   } else {
 106    @postings = @{&get_spool($config{'spooldir'})};
 107   };
 108  } else {
 109   @postings = @{&get_stdin($config{'pipeformat'})};
 110  };
 111  print STDERR "\n>>>>> Data parsed.\n\n" if (!$options{'q'});
 112
 113  # Daten speichern, falls verlangt
 114  if ($options{'w'}) {
 115   &writedata($options{'w'},\@postings);
 116  }
 117 };
 118
 119 # Postings auswerten
 120 $newsgrouplgth = 0;
 121 $posterrawlgth = 0;
 122 $posterlgth = 0;
 123 $subjectlgth = 0;
 124 $newsreaderlgth = 0;
 125
 126 foreach $posting (@postings) {
 127  %header = %{$posting};
 128  &day($header{'date'}) if $config{'day'};
 129  &newsgroups($header{'newsgroups'}) if $config{'newsgroups'};
 130  &poster($header{'from'}) if ($config{'poster'} or $config{'posterraw'});
 131  &subject($header{'subject'}) if $config{'subject'};
 132  &client($posting) if ($config{'newsreader'} or $config{'nruser'});
 133 };
 134
 135 # Nutzer pro Newsreader ermitteln
 136 if ($config{'nruser'}) {
 137  foreach $user (keys %userreader) {
 138   $nruser{$userreader{$user}}++;
 139   if (length($userreader{$user}) > $nruserlgth) { $nruserlgth = length($userreader{$user}); };
 140   $nrusersum++;
 141   #D print "!> $user: $userreader{$user}\n";
 142  };
 143 };
 144
 145 print STDERR "\n>>>>> Data analyzed.\n\n" if (!$options{'q'});
 146
 147 # Ausgabe generieren
 148 $output = "Auswertung";
 149 if ($config{'newsgroup'}) { $output .= " für $config{'newsgroup'}"; };
 150 print center($output);
 151 if ($config{'start'} || $config{'stop'}) {
 152  $output = '';
 153  if ($config{'start'}) { $output .= "von $config{'start'} "; };
 154  if ($config{'stop'}) { $output .= "bis $config{'stop'}"; };
 155  print center($output);
 156 };
 157 print center("=" x length($output))."\n";
 158
 159 # Postings pro Tag ermitteln und ausgeben
 160 if ($config{'day'}) {
 161  print center("Postings pro Tag");
 162  print center("----------------");
 163  &Date_Init("Language = German");
 164  $postcount = 0; $firstday = 0; $lastday = 0; $lastkw = 0; $lastmonat = 0;
 165  foreach $day (sort keys %datecount) {
 166   $firstday = $day if ($lastday == 0);
 167   $monat = UnixDate($day,"%B %Y");
 168   if ($monat ne $lastmonat) {
 169    if ($postcount > 0) {
 170     printf "\n\nPostings %-14s: %d (%.2f pro Tag)\n",$lastmonat,$postcount,($postcount / Date_DaysInMonth(UnixDate($lastday,"%m"),UnixDate($lastday,"%Y")));
 171    };
 172    $postcount = 0;
 173    print "\n\n".center($monat,50)."\n";
 174    print " KW :   Mo :  Di :  Mi :  Do :  Fr :  Sa :  So :\n";
 175    print "------------------------------------------------";
 176   };
 177   $kw = UnixDate($day,"%W");
 178   if ($kw != $lastkw && $lastkw > 0 && $monat eq $lastmonat) {
 179    for ($i=$lastkw+1; $i < $kw; $i++) {
 180     printf "\n %2.2d :",$i;
 181    };
 182   };
 183   if ($kw != $lastkw || $monat ne $lastmonat) {
 184    printf "\n %2.2d :",$kw;
 185    print " " x (6*(UnixDate($day,"%w")-1));
 186   } elsif ($lastday != 0 && $day-$lastday > 1) {
 187    print " " x (6*($day-$lastday-1));
 188   };
 189   printf " %5.5s",$datecount{$day};
 190   $postcount += $datecount{$day};
 191   $lastday = $day;
 192   $lastkw = $kw;
 193   $lastmonat = $monat;
 194  };
 195  if ($postcount > 0) {
 196   printf "\n\nPostings %-14s: %d (%.2f pro Tag)\n",$lastmonat,$postcount,($postcount / Date_DaysInMonth(UnixDate($lastday,"%m"),UnixDate($lastday,"%Y")));
 197  };
 198  $daycount = Delta_Format(DateCalc(ParseDate($firstday),ParseDate($lastday)),0,'%dh');
 199  #D print STDERR "$daycount = $lastday - $firstday\n";
 200  print "\n\n";
 201  if (scalar(@postings)) {
 202   printf "Postings insgesamt: %d (%.2f pro Tag)\n\n\n",scalar(@postings),scalar(@postings)/$daycount;
 203  } else {
 204   print "Keine Postings erfasst.\n\n\n";
 205  };
 206 };
 207 #D print &format_table(\%datecount,scalar(@postings),8,50,2,0,0);
 208
 209 # restliche Reports ausgeben
 210 foreach $report (@reports) {
 211  if ($config{$report}) {
 212   print center($reporttitel{$report});
 213   print center("-" x length($reporttitel{$report}))."\n";
 214   $reportlgth = $report.'lgth';
 215   $reportsum  = $report.'sum';
 216   $$reportsum = scalar(@postings) unless defined($$reportsum);
 217   print &format_table(\%$report,$$reportsum,$$reportlgth,$config{$report.'_width'},$config{$report.'_indent'},$config{$report.'_lines'},$config{$report.'_cutoff'},$config{$report.'_graph'});
 218   print "\n\n";
 219  };
 220 };
 221
 222 print "-- \n$0 v $ver [" . scalar(gmtime) . "]\n(c) 10/2003-10/2004 Thomas Hochstein * <thh\@inter.net>\n";
 223 exit;
 224
 225 # Subroutinen #########################
 226
 227 sub get_stdin {
 228  # Header aus Postings auslesen (gepipete Datei)
 229  #  IN: $format
 230  #      (MBOX-File oder data.dat, gepiped in STDIN)
 231  # OUT: Referenz auf @postings, das jeweils
 232  #      Referenzen auf %header (die Header) enthält
 233  my $format = shift; # Format der zu verarbeitenden Datei
 234  my ($trigger,$hname,$hcontents,%header,@postings,%midcache,$exit);
 235  if ($format eq 'hamster') {
 236   $trigger = '^.{4}X-Hamster-Info: ';
 237  } else {
 238   # Default: mbox
 239   $trigger = '^From \S+\@\S+ ';
 240  };
 241  while (<>) {
 242   # Neues Posting beginnt?
 243   if (/$trigger/o) {
 244    $exit = 0;
 245    PARSELOOP:
 246    while (<>) {
 247     # Leerzeile = Header beendet
 248     if (/^$/) {last PARSELOOP; }
 249     chomp;
 250     # Gefoldete Header an letzten anhängen
 251     if (/^\s+/) {
 252      s/^\s*(.+)\s*$/$1/;
 253      # $header{lc($hname)} .= "\n\t$_";
 254      if (/^=\?/) {
 255       $header{lc($hname)} .= $_;
 256      } else {
 257       $header{lc($hname)} .= " $_";
 258      };
 259     # Normale Header
 260     } else {
 261      ($hname,$hcontents) = split /:/,$_,2;
 262      $hcontents =~ s/^\s*(.+)/$1/;
 263      # richtige Newsgroup, falls gesetzt?
 264      if (exists($config{'newsgroup'}) && $config{'newsgroup'} ne '' && lc($hname) eq 'newsgroups' && lc($hcontents) !~ /$config{'newsgroup'}/) {
 265       #D print STDERR "ERROR: not $config{'newsgroup'}\n";
 266       $exit = 1;
 267       last PARSELOOP;
 268      # richtiger Datumsbereich, falls gesetzt?
 269      } elsif (lc($hname) eq 'date' && ((exists($config{'start'}) && $config{'start'} ne '' && Date_Cmp($hcontents,$config{'start'}) < 0) or (exists($config{'stop'}) && $config{'stop'} ne '' && Date_Cmp($hcontents,$config{'stop'}.' 23:59:59') > 0))) {
 270       #D print STDERR "ERROR: $hcontents not between $config{'start'} and $config{'stop'}\n";
 271       $exit = 1;
 272       last PARSELOOP;
 273      # Posting schonmal erfasst? MID-cache
 274      } elsif (lc($hname) eq 'message-id' && exists($midcache{$hcontents})) {
 275       #D print STDERR "ERROR: $hcontents was already cached\n";
 276       $exit = 1;
 277       last PARSELOOP;
 278      };
 279      $header{lc($hname)} = $hcontents;
 280     };
 281    };
 282    #D $count++; print "--$count--".$header{'message-id'}."\n";
 283    # Referenz auf Kopie von %header in @postings einhängen & MID cachen
 284    if (!$exit) {
 285     #D print "! $header{'message-id'}\n";
 286     #D print "> $header{'from'}\n";
 287     #D print "> $header{'newsgroups'}\n";
 288     #D print "> $header{'date'}\n";
 289     #D print "-----\n";
 290     $midcache{$header{'message-id'}}++;
 291     push @postings, { %header };
 292    };
 293    undef %header;
 294   };
 295  };
 296  return \@postings;
 297 };
 298
 299 sub get_spool {
 300  # Header aus Postings auslesen (Dateien im Spool)
 301  #  IN: $verzeichnis
 302  # OUT: Referenz auf @postings, das jeweils
 303  #      Referenzen auf %header (die Header) enthält
 304  # Globale Variablen, die gesetzt werden:
 305  #      %midcache;
 306  my $verzeichnis = shift;
 307  my ($file,$hname,$hcontents,%header,@postings,$exit);
 308  opendir(SPOOL,$verzeichnis) || print STDERR "ERROR: Could not open spool directory $verzeichnis: $!";
 309  FILELOOP:
 310  while(defined($file = readdir(SPOOL))) {
 311   if($file =~/^\./) { next FILELOOP; };
 312   #D print "!-> $file\n";
 313   open POSTING, "<$verzeichnis/$file" || print STDERR "ERROR: Could not open article file $verzeichnis/$file for reading: $!";
 314   $exit = 0;
 315   PARSELOOP:
 316   while(<POSTING>) {
 317    # Leerzeile = Header beendet
 318    if (/^$/) {last PARSELOOP; }
 319    chomp;
 320    # Gefoldete Header an letzten anhängen
 321    if (/^\s+/) {
 322     s/^\s*(.+)\s*$/$1/;
 323     # $header{lc($hname)} .= "\n\t$_";
 324     if (/^=\?/) {
 325      $header{lc($hname)} .= $_;
 326     } else {
 327      $header{lc($hname)} .= " $_";
 328     };
 329    # Normale Header
 330    } else {
 331     ($hname,$hcontents) = split /:/,$_,2;
 332     $hcontents =~ s/^\s*(.+)/$1/;
 333     # richtige Newsgroup, falls gesetzt?
 334     if (exists($config{'newsgroup'}) && $config{'newsgroup'} ne '' && lc($hname) eq 'newsgroups' && lc($hcontents) !~ /$config{'newsgroup'}/) {
 335      #D print STDERR "ERROR: not $config{'newsgroup'}\n";
 336      $exit = 1;
 337      last PARSELOOP;
 338     # richtiger Datumsbereich, falls gesetzt?
 339     } elsif (lc($hname) eq 'date' && ((exists($config{'start'}) && $config{'start'} ne '' && Date_Cmp($hcontents,$config{'start'}) < 0) or (exists($config{'stop'}) && $config{'stop'} ne '' && Date_Cmp($hcontents,$config{'stop'}).' 23:59:59' > 0))) {
 340      #D print STDERR "ERROR: $hcontents not between $config{'start'} and $config{'stop'}\n";
 341      $exit = 1;
 342      last PARSELOOP;
 343     # Posting schonmal erfasst? MID-cache
 344     } elsif (lc($hname) eq 'message-id' && exists($midcache{$hcontents})) {
 345      #D print STDERR "ERROR: $hcontents was already cached\n";
 346      $exit = 1;
 347      last PARSELOOP;
 348     };
 349     $header{lc($hname)} = $hcontents;
 350    };
 351   };
 352   # Referenz auf Kopie von %header in @postings einhängen & MID cachen
 353   if (!$exit) {
 354    $midcache{$header{'message-id'}} = 1 ;
 355    push @postings, { %header };
 356   };
 357   undef %header;
 358   # print "! $header{'message-id'}\n";
 359   # print "> $header{'from'}\n";
 360   close(POSTING);
 361  };
 362  closedir(DIR);
 363  return \@postings;
 364 };
 365
 366 sub get_spool_recursive {
 367  # Header aus Postings auslesen (Dateien im Spool, mehrere Spoolverzeichnisse)
 368  # ruft &get_spool rekursiv auf
 369  #  IN: $wurzelverzeichnis
 370  # OUT: Referenz auf @postings, das jeweils
 371  #      Referenzen auf %header (die Header) enthält
 372  my $wurzelverzeichnis = shift;
 373  my (@verzeichnisse, $verzeichnis);
 374  find sub { -d $File::Find::name && push @verzeichnisse, $File::Find::name }, $wurzelverzeichnis;
 375  foreach $verzeichnis (@verzeichnisse) {
 376   push @postings, @{&get_spool($verzeichnis)};
 377  };
 378  return \@postings;
 379 };
 380
 381 sub day {
 382  # Postings pro Tag ermitteln
 383  #  IN: Date:-Header des jeweiligen Postings
 384  # OUT: ---
 385  # Globale Variablen, die gesetzt werden:
 386  #    %datecount;
 387  my $datum = shift;
 388  if ($datum = UnixDate($datum,"%Y%m%d")) {
 389   $datecount{$datum}++;
 390  };
 391  #D print ">> $datum\n";
 392  return;
 393 };
 394
 395 sub poster {
 396  # Poster (mit vollem From + nur mit Namen) auswerten
 397  #  IN: From:-Header des jeweiligen Postings
 398  # OUT: ---
 399  # Globale Variablen, die gesetzt werden:
 400  #    %posterraw;
 401  #    %poster;
 402  #    $posterrawlgth;
 403  #    $posterlgth;
 404  my $from = shift;
 405  my $name;
 406  ($from) = Mail::Address->parse($from);
 407  if (defined($from)) {
 408   # Postings pro Poster (nach Namen im From:)
 409   $name = $from->format;
 410  } else {
 411   $name = '(unbekannt)';
 412  };
 413  if ($name eq '') { $name = '(unbekannt)'; };
 414  $posterraw{$name}++;
 415  if (length($name) > $posterrawlgth) { $posterrawlgth = length($name); };
 416  if (defined($from)) {
 417   # Postings pro Poster (nach From:)
 418   $name = &mime_decode($from->name);
 419  };
 420  #D print "::>> $name\n";
 421  $poster{$name}++;
 422  if (length($name) > $posterlgth) { $posterlgth = length($name); };
 423  #D print "!> $address : $name\n";
 424  return;
 425 };
 426
 427 sub subject {
 428  # Subject auswerten
 429  #  IN: Subject:-Header des jeweiligen Postings
 430  # OUT: ---
 431  # Globale Variablen, die gesetzt werden:
 432  #    %subject;
 433  #    $subjectlgth;
 434  # Subject decodieren
 435  my $subject = shift;
 436  $subject = &mime_decode($subject);
 437  $subject =~ s/^(re|aw): (.+)/$2/i;
 438  # Postings mit entsprechendem Subject
 439  $subject{$subject}++;
 440  if (length($subject) > $subjectlgth) { $subjectlgth = length($subject); };
 441  #D print "!> $subject\n";
 442  return;
 443 };
 444
 445 sub newsgroups {
 446  # Newsgroup auswerten
 447  #  IN: Newsgroup:-Header des jeweiligen Postings
 448  # OUT: ---
 449  # Globale Variablen, die gesetzt werden:
 450  #    %newsgroups;
 451  #    $newsgroupslgth;
 452  #    $newsgroupssum:
 453  # Newsgroup decodieren - wohl nicht erforderlich?
 454  my $newsgroup;
 455  my $newsgroups = shift;
 456  #D print "!> $newsgroup\n";
 457  # $newsgroups = &mime_decode($newsgroups);
 458  my @newsgroups = split /,/,$newsgroups;
 459  # Postings in entsprechende Newsgroups
 460  foreach $newsgroup (@newsgroups) {
 461   # auch Crossposts als Inkarnation zählen
 462   $newsgroupssum++;
 463   chomp($newsgroup);
 464   $newsgroups{$newsgroup}++;
 465   if (length($newsgroup) > $newsgroupslgth) { $$newsgroupslgth = length($newsgroup); };
 466   #D print "--> $newsgroup\n";
 467  }
 468  return;
 469 };
 470
 471 sub client {
 472  # Newsreader zu ermitteln versuchen
 473  #  IN: Referenz auf %header des jeweiligen Postings
 474  # OUT: ---
 475  # Globale Variablen, die gesetzt werden:
 476  #    %newsreader;
 477  #    $newsreaderlgth;
 478  #    %userreader;
 479  my $posting = shift;
 480  my %header = %{$posting};
 481  my ($newsreader);
 482  # zutreffenden Header ermitteln, mit Präzedenz User-Agent -> X-Newsreader -> X-Mailer
 483  if (defined($header{'user-agent'}) && $header{'user-agent'} !~ /^hamster/i) {
 484   $newsreader = &mime_decode($header{'user-agent'});
 485  } elsif(defined($header{'x-newsreader'})) {
 486   $newsreader = &mime_decode($header{'x-newsreader'});
 487  } elsif(defined($header{'x-mailer'})) {
 488   $newsreader = &mime_decode($header{'x-mailer'});
 489  };
 490  # Newsreader zu ermitteln versuchen
 491  if ((defined($newsreader)) and ($newsreader ne '')) {
 492   #D print "! $newsreader\n";
 493   KNOWN: {
 494    $newsreader = 'Outlook Express', last KNOWN if $newsreader=~/Outlook Express/i;
 495    $newsreader = 'Mozilla', last KNOWN if ($newsreader=~/Mozilla/i and $newsreader!~/StarOffice/i);
 496    $newsreader = 'Star Office', last KNOWN if ($newsreader=~/Mozilla/i and $newsreader =~/StarOffice/i);
 497    $newsreader = 'Forté Agent', last KNOWN if ($newsreader=~/Forte.*Agent/i or $header{'message-id'}=~/^[a-zA-Z0-9=+]{28,34}\@/ or $header{'message-id'}=~/^$lt_alpha_num{8}\.\d{7,9}\@/o or $header{'message-id'}=~/^$lt_alpha_num{7}\.\d{2,3}\.\d\@/o);
 498    $newsreader = 'Xnews', last KNOWN if ($newsreader=~/Xnews/i or $header{'message-id'}=~/^$lt_alpha_num{6}\.$lt_alpha_num{2}\.\d\@/o);
 499    $newsreader = 'Gnus', last KNOWN if ($newsreader=~/Gnus/i or $header{'message-id'}=~/^$lt_alpha_num{10,11}\.fsf\@/o);
 500    $newsreader = 'slrn', last KNOWN if ($newsreader=~/slrn/i or $header{'message-id'}=~/^slrn$lt_alpha_num{6}\.$lt_alpha_num{2,3}\.\w+\@/o);
 501    $newsreader = 'MacSOUP', last KNOWN if ($newsreader=~/MacSOUP/i or $header{'message-id'}=~/^$lt_alpha_num{7}\.$lt_alpha_num{13,14}[A-Z]\%[a-zA-Z\.]+\@/o);
 502    $newsreader = 'Gravity', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^MPG\.$lt_hex_nibb{22}\@/o);
 503    $newsreader = 'Pine', last KNOWN if ($newsreader=~/Pine/i or $header{'message-id'}=~/^Pine\.$gt_alpha_num{3}\.\d\.\d{2}\.\d{14}\.\d{4,5}-\d{6}\@/o);
 504    $newsreader = 'Crosspoint', last KNOWN if ($newsreader=~/Crosspoint/i or $header{'message-id'}=~/^[a-zA-Z0-9\$\-]{11}\@/o);
 505    $newsreader = 'Crosspoint/OpenXP', last KNOWN if ($newsreader=~/OpenXP/);
 506    $newsreader = 'Pan', last KNOWN if ($newsreader=~/Pan/);
 507    $newsreader = 'Fortitude Dialog', last KNOWN if ($newsreader=~/Dialog/i);
 508    $newsreader = 'tin', last KNOWN if ($newsreader=~/tin\//);
 509    $newsreader = 'KNode', last KNOWN if ($newsreader=~/KNode/);
 510    $newsreader = 'Opera', last KNOWN if ($newsreader=~/Opera/);
 511    $newsreader = 'Freenet-Webnews', last KNOWN if ($newsreader=~/Freenet-Webnews/i);
 512    $newsreader = 'NewsFleX', last KNOWN if ($newsreader=~/NewsFleX/i);
 513    $newsreader = 'knews', last KNOWN if ($newsreader=~/knews/i);
 514    $newsreader = 'WinVN', last KNOWN if ($newsreader=~/WinVN/i);
 515    $newsreader = 'nn', last KNOWN if ($newsreader=~/nn\//);
 516    $newsreader = 'Lotus Notes', last KNOWN if ($newsreader=~/Lotus.*Notes/);
 517    $newsreader = 'NewsPortal', last KNOWN if ($newsreader=~/NewsPortal/i);
 518    $newsreader = 'ProNews', last KNOWN if ($newsreader=~/ProNews/i);
 519    $newsreader = 'Sylpheed', last KNOWN if ($newsreader=~/Sylpheed/i);
 520    print STDERR "Unknown Newsreader: $newsreader\n" if (!$options{'q'});
 521    if($config{'unknownreader'} eq 'show')  {
 522     # $newsreader ist ja schon gesetzt
 523    } else {
 524     $newsreader = '(Sonstiger)';
 525    };
 526   }
 527  } else {
 528   $newsreader = '(keine Angabe)'
 529  };
 530  # Usernamen ermitteln und Newsreader dieses Nutzers setzen
 531  # (bei versch. Newsreadern zählt also der letzte)
 532  ($from) = Mail::Address->parse($header{'from'});
 533  if (defined($from)) {
 534   $name = $from->format;
 535   $userreader{$name} = $newsreader;
 536   #D print "> $userreader{$name}\n";
 537  };
 538  #D print "> $newsreader\n";
 539  if (length($newsreader) > $newsreaderlgth) { $newsreaderlgth = length($newsreader); };
 540  $newsreader{$newsreader}++;
 541  return;
 542 }
 543
 544 sub center {
 545  # Text mittig formatieren
 546  #  IN: $text, $width
 547  # OUT: (zentrierter Text)
 548  my $text  = shift; # Text
 549  my $width = shift; # Breite der Spalte
 550  chomp($text);
 551  $width ||= 70; # Defaultbreite: 70
 552  return ' 'x(($width-length($text))/2).$text."\n";
 553 };
 554
 555 sub format_table {
 556  # Tabelle formatieren
 557  #  IN: \%values, $sum, $longest, $maxwidth, $indent, $lines, $cutoff, $graph
 558  # OUT: $output (formatierte Tabelle)
 559  my $values     = shift; # Referenz auf %values
 560  my $sum        = shift; # Gesamtsumme (fuer Prozentwert)
 561  my $longest    = shift; # Längster Index von %values
 562  my $maxwidth   = shift; # Maximale Spaltenbreite für den Index
 563  my $indent     = shift; # Einzug links
 564  my $lines      = shift; # Maximale Zeilenzahl der Tabelle
 565  my $cutoff     = shift; # Minimaler anzuzeigender Wert
 566  my $graphwidth = shift; # Spaltenbreite für Graph
 567  my %values = %{$values};
 568  my ($output,$value,$outputvalue,$valuelongest,$place,$outputplace,$lastvalue,$notdisplayed,$percent,$maxpercent,$graph,$graphlength);
 569  # $maxwidth auf minimal 10 setzen und $longest an $maxwidth anpassen
 570  if ($maxwidth > 0) {
 571   if ($maxwidth < 10) { $maxwidth = 10; };
 572   if ($longest > $maxwidth) { $longest = $maxwidth; };
 573  };
 574  # $lines auf minimal 3 setzen
 575  if ($lines > 0 && $lines < 3) { $lines = 3; };
 576  # Tabelle ausgeben
 577  $lastvalue = 0;
 578  foreach $value (sort {$values{$b} <=> $values{$a}} keys %values) {
 579   # Prozentzahl berechnen
 580   $percent = 100*$values{$value}/$sum;
 581   # Platzziffer setzen, ggf. unterdrücken, falls selber Wert wie zuvor
 582   $place++; $outputplace = '';
 583   if ($lastvalue != $values{$value}) { $outputplace = $place.'.'; };
 584   $outputvalue = $value;
 585   # Platz 1 hat größten Wert -> höchste Breite für Wertespalte und höchsten Prozentwert ermitteln
 586   if ($place == 1) {
 587    $valuelongest = length($values{$value});
 588    $maxpercent = $percent;
 589   };
 590   # falls Index zu breit: kürzen und "[...]" anhängen
 591   if ($maxwidth > 0 && length($value) > $maxwidth) {
 592    $outputvalue = substr($value,0,$maxwidth-5)."[...]";
 593   };
 594   # Balkengrafik generieren
 595   if ($graphwidth > 0) {
 596    $graphlength = int($percent*$graphwidth/$maxpercent);
 597    $graph = '|'.$config{'graphchar'}x$graphlength.' 'x($graphwidth-$graphlength).'|';
 598   } else {
 599    $graph = ''
 600   };
 601   # Zeilen ausgeben, bis maximale Zeilenzahl oder Grenzwert erreicht (in letzterem Fall aber mind. 1 Zeile)
 602   if (($lines < 1 || $place <= $lines) && ($cutoff < 1 || $place < 2 || $values{$value} >= $cutoff)) {
 603    $output .= ' 'x$indent.sprintf "%4s %-${longest}s: %${valuelongest}s (%5.2f%%) %${graphwide}s\n", $outputplace, $outputvalue, $values{$value}, $percent, $graph;
 604   # falls Zeile nicht mehr ausgegeben: mitzählen
 605   } else {
 606    $notdisplayed++;
 607   };
 608   $lastvalue = $values{$value};
 609  };
 610  # "(+ ... weitere)"
 611  if (($lines > 0 && $place > $lines) or ($cutoff > 0 && $lastvalue < $cutoff)) {
 612   $output .= ' 'x($indent+4)."(+ $notdisplayed weitere";
 613   if ($cutoff > 0 || $values{$value} < $cutoff) {
 614    $output .= " mit < $cutoff";
 615   };
 616   $output .= ")\n";
 617  };
 618  $output .= ' 'x$indent.'-'x(16+$longest+$valuelongest)."\n";
 619  $output .= ' 'x($indent+6+$longest).sprintf "%${valuelongest}s ( 100% )\n", $sum;
 620  return $output;
 621 };
 622
 623 sub readconfig {
 624  # Konfigurationsdatei auslesen
 625  #  IN: Name der Konfigurationsdatei
 626  # OUT: ---
 627  # Globale Variablen, die gesetzt werden:
 628  #    %config;
 629  my $conffile = shift;
 630  if (-e $conffile) {
 631   open CONFIG, "<$conffile" || print STDERR "ERROR: Could not open config file $conffile for reading: $!";
 632  } else {
 633   print STDERR "ERROR: Config file $conffile does not exist!\n";
 634   return;
 635  };
 636  while(<CONFIG>) {
 637   chomp;
 638   s/#.*//;
 639   s/^\s+//;
 640   s/\s+$//;
 641   next unless length;
 642   my($option,$value) = split(/\s*=\s*/, $_, 2);
 643   $config{$option} = $value;
 644   #D print "$option: $value\n;"
 645  };
 646  close CONFIG;
 647  return;
 648 };
 649
 650 sub mime_decode {
 651  # Header mit MIME-Words decodieren
 652  #  IN: $mimeheader - potentiell codierter Header
 653  # OUT: $decoded - decodierte Zeile
 654  my $mimeheader = shift;
 655  my ($mimeword, $decoded);
 656  foreach $mimeword (decode_mimewords($mimeheader)) {
 657   my ($data, $encoding) = @{$mimeword};
 658   #D printf "Enc: %12s %s \n", $encoding, $data;
 659   if ($encoding ne '') {
 660    $encoding = uc($encoding);
 661    my $convert = Locale::Recode->new (from => $encoding,
 662                                       to   => $config{'charset'});
 663    print STDERR 'Recode: '.$convert->getError."\n" if $convert->getError;
 664    $convert->recode ($data) or print STDERR 'Recode: '.$convert->getError."\n";
 665    #D printf " >>> %12s %s \n", $encoding, $data;
 666   };
 667   $decoded .= $data;
 668  };
 669  return $decoded;
 670 };
 671
 672 sub writedata {
 673  # --> Perl-Kochbuch, Rezept 11.10
 674  # Datendatei (Header) schreiben
 675  #  IN: $datei - Name der Datendatei
 676  #      Referenz auf @postings
 677  # OUT: ---
 678  my $datei = shift;
 679  my $postingr = shift;
 680  my @postings = @{$postingr};
 681  open DATEI, ">$datei" || print STDERR "ERROR: Could not open file $datei for writing: $!";
 682  foreach $posting (@postings) {
 683   for $header (sort keys %{$posting}) {
 684    print DATEI "$header: $posting->{$header}\n";
 685   }
 686   print DATEI "\n";
 687  };
 688  close DATEI;
 689  return;
 690 };
 691
 692 sub readdata {
 693  # --> Perl-Kochbuch, Rezept 11.10
 694  # Datendatei (Header) einlesen
 695  #  IN: $datei - Name der Datendatei
 696  # OUT: Referenz auf @postings, das jeweils
 697  #      Referenzen auf %header (die Header) enthält
 698  my $datei = shift;
 699  open DATEI, "<$datei" || print STDERR "ERROR: Could not open file $datei for reading: $!";
 700  $/ = '';
 701  while (<DATEI>) {
 702   my @fields = split /^([^:]+):\s*/m;
 703   shift @fields;
 704   push(@postings, {map/(.*)/, @fields});
 705  };
 706  close DATEI;
 707  return \@postings;
 708 };