Subversion Repositories LCARS

#!/usr/bin/env perl

use strict;

use warnings;

require 5.004;

#use diagnostics;

use utf8;

## NOTE:

## Enable and remove binmode when utf8::all has actually become lexically scoped

# use utf8:all;

use constant DEBUG => 0;

## newsstat.pl

## Copyright (C) 2011, 2012  Thomas Lahn <startrek@PointedEars.de>

## Based on work by Garry Knight et al.

##

## This program is free software: you can redistribute it and/or modify

## it under the terms of the GNU General Public License as published by

## the Free Software Foundation, either version 3 of the License, or

## (at your option) any later version.

##

## This program is distributed in the hope that it will be useful,

## but WITHOUT ANY WARRANTY; without even the implied warranty of

## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

## GNU General Public License for more details.

##

## You should have received a copy of the GNU General Public License

## along with this program.  If not, see <http://www.gnu.org/licenses/>.

## Print out all text to STDOUT UTF-8 encoded

binmode STDOUT, ':encoding(UTF-8)';

binmode STDERR, ':encoding(UTF-8)';

## L10n

use locale ':not_characters';

# setlocale( LC_MESSAGES, '' );

require Number::Format;

## i18n

## FIXME: Automatically include resolved '.' in @INC

# print join "\n", @INC;

use Locale::TextDomain ('de.pointedears.newsstat');

use POSIX              ('locale_h');

use Locale::Messages qw (bind_textdomain_filter

  bind_textdomain_codeset

  turn_utf_8_on);

bind_textdomain_filter 'de.pointedears.newsstat',  \&turn_utf_8_on;

bind_textdomain_codeset 'de.pointedears.newsstat', 'utf-8';

require Mail::Message;

require DateTime;

require DateTime::Format::Mail;

# See comments in previous example

my ( $thousands_sep, $mon_thousands_sep, $grouping, $decimal_point ) =

  @{ localeconv() }{ 'thousands_sep', 'mon_thousands_sep', 'grouping',

  'decimal_point' };

# Apply defaults if values are missing

$thousands_sep = $mon_thousands_sep unless $thousands_sep;

$thousands_sep = ' ' unless $thousands_sep;

# grouping and mon_grouping are packed lists

# of small integers (characters) telling the

# grouping (thousand_seps and mon_thousand_seps

# being the group dividers) of numbers and

# monetary quantities.  The integers' meanings:

# 255 means no more grouping, 0 means repeat

# the previous grouping, 1-254 means use that

# as the current grouping.  Grouping goes from

# right to left (low to high digits).  In the

# below we cheat slightly by never using anything

# else than the first grouping (whatever that is).

my @grouping;

if ($grouping)

{

  @grouping = unpack( "C*", $grouping );

}

else

{

  @grouping = (3);

}

## FIXME: Why don't the defaults work already?

my $formatter = new Number::Format(

  -decimal_point => $decimal_point,

  -thousands_sep => $thousands_sep,

  -kibi_suffix   => ' KiB',

  -mebi_suffix   => ' MiB',

  -gibi_suffix   => ' GiB',

  # -grouping      => $grouping[0]

);

###################### USER CONFIGURATIONS ############################

## The name of the group to do stats for

my $newsgroup_name = $ARGV[0];

$newsgroup_name // usage();

## Check for removal flags

my $ix;

my $j;

my %skipSec;

my @skiplist;

my $args = @ARGV;

for ( $ix = 1 ; $ix < $args ; $ix++ )

{

  $j = $ix + 1;

  if ( $ARGV[$ix] eq "-x" )

  {

    @skiplist = split( ",", $ARGV[$j] );

  }

  elsif ( $ARGV[$ix] =~ /-x(\d.*)/ )

  {

    @skiplist = split( ",", $1 );

  }

}

foreach (@skiplist)

{

  $skipSec{$_} = 1;

}

## Leafnode users will want /var/spool/news for this variable.

my $news = "/var/spool/news/";

## Number of top or bottom posters to show

my $topposters = 20;

## Number of threads we want to know about

my $topthreads = 20;

## Number of cross-posted threads to show

my $topcrossposts = 10;

## Number of agents we list

my $topagents = 10;

## Number of time zones to show

my $toptz = 10;

###################### DATA STRUCTURES ######################

my $group = $newsgroup_name;

$group =~ s!\.!/!g;

my %data;    # name, count, agent, total, orig, quoted

my $totsize = 0;    # holds total sizes of all files

my %crossposts;     # group, count

my %threads;        # subject, count

my $replies   = 0;  # total no. of replies

my $origposts = 0;  # total no. of original posts

my %tz;             # timezones by count

my $earliest;       # earliest article we have found

my $latest;         # latest article we have found

my $totheader = 0;  # total size of header material

my $totbody   = 0;  # total size of body material

my $totsig    = 0;  # total size of sig material

my $totquoted = 0;  # total size of quoted material

my $totorig   = 0;  # total size of original material

my $totalposts;     # total no. of posts considered

my %distinct_agent;

## Used to hold counts of User Agents used

my %agents = (

  "Compuserver"               => 0,

  "Foorum"                    => 0,

  "Forte Agent"               => 0,

  "Forte Free Agent"          => 0,

  "Gnus"                      => 0,

  "KNode"                     => 0,

  "MacSOUP"                   => 0,

  "MT-NewsWatcher"            => 0,

  "MicroPlanet Gravity"       => 0,

  "Microsoft Outlook Express" => 0,

  "Microsoft Windows Mail"    => 0,

  "Mozilla"                   => 0,

  "News Rover"                => 0,

  "NN"                        => 0,

  "Pan"                       => 0,

  "rn"                        => 0,

  "slrn"                      => 0,

  "Sylpheed"                  => 0,

  "tin"                       => 0,

  "VSoup"                     => 0,

  "WebTV"                     => 0,

  "Xnews"                     => 0,

);

my $datetime_parser = DateTime::Format::Mail->new();

$datetime_parser->loose();

my $today = DateTime->today( time_zone => 'UTC' );

my $prev_month = $today->clone()->subtract( months => 1 )->set_day(1);

my $start      = int $prev_month->strftime('%s');

my $numdays    = int DateTime->last_day_of_month(

  year      => $prev_month->year(),

  month     => $prev_month->month(),

  time_zone => $prev_month->time_zone(),

)->day();

my $end = int $today->clone()->set_day(1)->strftime('%s');

dmsg( $start, " to ", $end ) if DEBUG;

chdir("$news$group")

  or die __x(

  "Can't cd to {newsgroup}: {error}\n",

  newsgroup => "$news$group",

  error     => $!

  );

opendir( DIR, "." )

  or die __x(

  "Can't open {newsgroup}: {error}\n",

  newsgroup => "$news$group",

  error     => $!

  );

while ( defined( my $filename = readdir(DIR) ) )

{

  next unless -f $filename;    # only want real files

  next if ( $filename eq ".overview" );    # real articles only

  get_article($filename);                  # read in the article

}

closedir(DIR);                             # finished with the directory

dmsg("\nearliest: $earliest\nlatest:   $latest") if DEBUG;

## Post-processing

count_agents();                            # count agents, collapsing versions

fix_percent();

write_data();

display_results();

########################################

## Get current article's header and body

########################################

sub get_article

{

  my $filename = shift;

  open( my $FILE, '<', $filename )

    or

    die __x( "Can't open {file}: {error}\n", file => $filename, error => $! );

  my $msg       = Mail::Message->read($FILE);

  my $timestamp = $msg->timestamp();

  my $date      = $msg->study('Date');

  ## Disregard article if timestamp is not in range

  dmsg($timestamp) if DEBUG;

  if ( $timestamp < $start || $timestamp >= $end )

  {

    dmsg("Posting on $date ignored.") if DEBUG;

    return;

  }

  $totalposts++;    # bump count of articles considered

  ## DEBUG

  dmsg($date) if DEBUG;

  ## get stats about the file itself

  my $filesize = -s $filename;    # get total size of file

  $totsize += $filesize;          # bump total sizes of all files

  if ( ( not defined $earliest ) || $timestamp < $earliest )

  {

    $earliest = $timestamp;

  }

  elsif ( ( not defined $latest ) || $timestamp > $latest )

  {

    $latest = $timestamp;

  }

  #print "timestamp: $timestamp\n";

  ## count header size

  $totheader += $msg->head()->size();

  ## get the poster's name (MIME-decoded, in UTF-8)

  my $poster = $msg->study('From');

  if ( defined $poster )

  {

    ## Convert old to new format

    $poster =~ s/^\s*(.+?\@.+?)\s*\((.+?)\)\s*$/$2 <$1>/;

    ## Collapse whitespace

    $poster =~ s/\s+/ /g;

    ## Remove outer quotes; TODO: observe RFC 5322 strictly

    $poster =~ s/^ " (.+ ) " \s+ (.*)/$1 $2/x;

    ## DEBUG

    dmsg($poster) if DEBUG;

    ## seen this one before?

    if ( !defined( $data{$poster} ) )

    {

      $data{$poster}{'agent'}  = __ 'unknown';    # comes after For: field

      $data{$poster}{'orig'}   = 0;

      $data{$poster}{'quoted'} = 0;

    }

    $data{$poster}{'count'}++;                    # bump count for this poster

    $data{$poster}{'size'} += $filesize;          # total size of file

    ## The User-Agent and/or X-Newsreader fields

    ## for User-Agent by poster

    my $ua = $msg->study('User-Agent') // $msg->study('X-Newsreader');

    if ( defined $ua )

    {

      $data{$poster}{'agent'} = $ua;

      ## DEBUG

      dmsg($ua) if DEBUG;

    }

    ## The User Agent for User-Agent by number of articles

    get_agent($msg);

    ## Get all cross-posted newsgroups

    for ( split( /,/, $msg->study('Newsgroups') ) )

    {

      $crossposts{$_}++;    # bump count for each

    }

    ## Get threads

    my $thread = $msg->study('Subject');

    $thread =~ s/^\s*re:\s*//i;              # Remove Re: or re: at the start

    $thread =~ s/\s*\(was:\s*.*\)\s*$//i;    # Remove (was: ...) at the end

    $thread =~ s/\s+/ /g;                    # collapse whitespace

    $threads{$thread}{'count'}++;            # bump count of this subject

    $threads{$thread}{'size'} += $filesize;  # bump bytes for this thread

    ## Is this an original post or a reply?

    if ( defined $msg->study('References') )

    {

      $replies++;

    }

    else

    {

      $origposts++;

    }

    ## Get the time zone

    my $datetime = $datetime_parser->parse_datetime($date);

    my $tz       = $datetime->strftime('%z');

    $tz = "UTC" if $tz =~ m{^(?:GMT|0000)$}o;

    $tz{$tz}++;

    ## DEBUG

    dmsg($tz) if DEBUG;

#### Now analyse the body text ####

    my $body = $msg->body();

    my $insig = 0;

    my @body  = $body->lines;

    for (@body)

    {

      $totbody += length($_);    # bump total body size

      next if (m{^$>}o);         # don't count blank lines in body

      if ( $insig == 1 )

      {

        # bump total sig size

        $totsig += length($_);

      }

      ## are we in a quote line?

      ## Bill Unruh uses ] quotes, and another poster uses ::

      elsif ( m{^\s*[>\]]}o || m{^\s*::}o )

      {

        ## bump count of quoted chrs

        $data{$poster}{'quoted'} += length($_);

        $totquoted += length($_);

      }

      elsif (/^-- $/)

      {

        $insig = 1;

      }

      else

      {

        ## We must be processing an original line

        $data{$poster}{'orig'} += length($_);    # bump count of original chrs

        $totorig += length($_);

      }

    }

    # end for (@body)

  }

  close($FILE);

}

sub get_agent

{

  my $msg = shift;

  my $ua = $msg->study('User-Agent') // $msg->study('X-Newsreader')

    // $msg->study('X-Mailer');

  if ( not defined $ua )

  {

    my $org = $msg->study('Organization');

    if ( defined $org

      and $org =~ /groups\.google|AOL|Supernews|WebTV|compuserve/ )

    {

      $ua = $org;

    }

    elsif ( $msg->study('Message-ID') =~ /pine/i )

    {

      $ua = "Pine";

    }

  }

  ## Hopefully found UA, else set to unknown

  if ( not defined $ua )

  {

    $ua = __ "unknown";

  }

  $ua = clean($ua);

  my $raw   = $ua;

  my $agent = $raw;

  ## strip http

  if ( $raw =~ /.*http.*/ )

  {

    $raw =~ s!posted via!!i;

    $raw =~ s!http://!!g;

    $raw =~ s!/!!g;

    $raw =~ s! !!g;

  }

  ## Fix Outlook from Mac

  if ( $raw =~ /^microsoft/i )

  {

    $raw =~ s/-/ /g;

  }

  ## Pick out the popular agents

  if ( $raw =~ /(outlook express)/i

    || $raw =~ /(windows mail)/i

    || $raw =~ /(microplanet gravity)/i

    || $raw =~ /(news rover)/i

    || $raw =~ /(forte agent)/i

    || $raw =~ /(forte free agent)/i )

  {

    $agent = $1;

  }

  elsif (

    $raw =~ /^(

        pan

       |sylpheed

       |slrn

       |mozilla

       |knode

       |tin

       |hamster

       |xrn

       |xnews

       |aol

       |gnus

       |krn

       |macsoup

       |messenger

       |openxp

       |pine

       |thoth

       |turnpike

       |winvn

       |vsoup

       |google

       |supernews

       |nn

       |rn

       |007

       |webtv

       |compuserve

       )/ix

    )

  {

    $agent = $1;

  }

  else

  {

    ## Clean up unknown agents

    if ( $raw =~ m!^(.*?)/! )

    {

      $agent = $1;

    }

    elsif ( $raw =~ /^(\w*)\d.*/ )

    {

      $agent = $1;

    }

  }

  $distinct_agent{$agent}++;

  return $agent;

}

## get_agent

#########################################

## Count the User-Agents used, collapsing

## different versions into one per agent.

#########################################

sub count_agents

{

POSTER:

  foreach my $poster ( keys %data )

  {

    foreach my $agent_name ( keys %distinct_agent )

    {    # check against known ones

      if ( $data{$poster}{'agent'} =~ /\Q$agent_name\E/ )

      {

        $agents{$agent_name}++;

        next POSTER;

      }

    }

    $agents{ $data{$poster}{'agent'} }++;

  }

}    # count_agents

#############################################

## Set orig/total percentages for all posters

#############################################

sub fix_percent

{

  foreach my $poster ( keys %data )

  {

    my $percent = 100;

    if ( ( $data{$poster}{'orig'} != 0 ) and ( $data{$poster}{'quoted'} != 0 ) )

    {

      $percent =

        $data{$poster}{'orig'} * 100 /

        ( $data{$poster}{'quoted'} + $data{$poster}{'orig'} );    #/

    }

    elsif ( $data{$poster}{'orig'} == 0 )

    {

      $percent = 0;

    }

    $data{$poster}{'percent'} = $percent;

  }

}

## fix_percent

##################################

## Write data structures to a file

##################################

sub write_data

{

  open( my $OUTF, ">:encoding(UTF-8)", "/tmp/XDATA" )

    or die __x( "Can't create XDATA: {error}\n", error => $! );

  print $OUTF "Data collected from $newsgroup_name\n\n";

  print $OUTF

    "Poster Data\nname : agent : count : size: orig : quoted : per cent\n";

  foreach my $name ( keys %data )

  {

    print $OUTF

"$name : $data{$name}{'agent'} : $data{$name}{'count'} : $data{$name}{'size'} : $data{$name}{'orig'} : $data{$name}{'quoted'} : $data{$name}{'percent'}\n";

  }

  print $OUTF

"============================================================================\n";

  print $OUTF "Thread subjects\n";

  print $OUTF

"----------------------------------------------------------------------------\n";

  foreach my $thread ( sort { "\L$a" cmp "\L$b" } keys %threads )

  {

    print $OUTF

      "$thread : $threads{$thread}{'count'} : $threads{$thread}{'size'}\n";

  }

  print $OUTF

"============================================================================\n";

  print $OUTF "Cross-posts\n";

  print $OUTF

"----------------------------------------------------------------------------\n";

  foreach my $name ( sort keys %crossposts )

  {

    print $OUTF "$name : $crossposts{$name}\n";

  }

  print $OUTF

"============================================================================\n";

  print $OUTF "User agents\n";

  print $OUTF

"----------------------------------------------------------------------------\n";

  foreach my $name ( sort keys %agents )

  {

    print $OUTF "$name : $agents{$name}\n";

  }

  print $OUTF

"============================================================================\n";

  print $OUTF "Time zones\n";

  print $OUTF

"----------------------------------------------------------------------------\n";

  foreach my $name ( sort keys %tz )

  {

    print $OUTF "$name : $tz{$name}\n";

  }

  close $OUTF;

}    # write_data

sub display_results

{

  #################### DISPLAY RESULTS #####################

  print "=" x 76, "\n";

  printf "%s\n",

    centred(

    __x( "Analysis of articles to {newsgroup}", newsgroup => $newsgroup_name ),

    76

    );

  print "=" x 76, "\n";

  printf "%s\n",

    centred(

    __(

"(compiled with a script by Thomas 'PointedEars' Lahn, based on work by\nGarry Knight et al.)"

    ),

    76

    );

  print "\n";

  printf __"Total articles considered:   %s over %d days\n",

    $formatter->format_number($totalposts),

    $formatter->format_number($numdays);

  my $time_locale       = setlocale(LC_TIME);

  my $earliest_datetime = DateTime->from_epoch(

    epoch     => $earliest,

    locale    => $time_locale,

    time_zone => 'UTC',

  );

  my $latest_datetime = DateTime->from_epoch(

    epoch     => $latest,

    locale    => $time_locale,

    time_zone => 'UTC',

  );

  my $datetime_format = '%a, %Y-%m-%dT%H:%M:%S %Z';

  printf __"Earliest article:            %s" . "\n",

    $earliest_datetime->strftime($datetime_format);

  printf __"Latest article:              %s" . "\n",

    $latest_datetime->strftime($datetime_format);

  printf __"Original articles:           %s; replies: %s" . "\n",

    $formatter->format_number($origposts),

    $formatter->format_number($replies);

  printf __"Total size of articles:      %s bytes (%s)" . "\n",

    $formatter->format_number($totsize),

    $formatter->format_bytes( $totsize, ( 'precision' => 1, 'mode' => 'iec' ) );

  printf __"Average %s articles per day, %s per day, %s bytes per article.\n",

    $formatter->format_number( int( $totalposts / $numdays ) ),

    $formatter->format_bytes( $totsize / $numdays, ( 'mode' => 'iec' ) ),

    $formatter->format_number( int( $totsize / $totalposts ) );

  my $count = keys %data;

  print "\n";

  printf __"Total headers:      %s; bodies: %s\n",

    $formatter->format_bytes(

    $totheader, ( 'precision' => 1, 'mode' => 'iec' )

    ),

    $formatter->format_bytes( $totbody, ( 'precision' => 1, 'mode' => 'iec' ) );

  printf __

    "Body text - quoted: %s; original: %s = %s%%; sigs: %s\n",

    $formatter->format_bytes(

    $totquoted, ( 'precision' => 1, 'mode' => 'iec' )

    ),

    $formatter->format_bytes( $totorig, ( 'precision' => 1, 'mode' => 'iec' ) ),

    $formatter->format_number( ( $totorig * 100 ) / ( $totorig + $totquoted ) )

    ,

    $formatter->format_bytes( $totsig, ( 'precision' => 1, 'mode' => 'iec' ) );

  print "\n";

  printf __"Total number of posters:     %s, average %s per poster\n",

    $formatter->format_number($count),

    $formatter->format_bytes( $totsize / $count,

    ( 'precision' => 1, 'mode' => 'iec' ) );

  $count = keys %threads;

  printf __"Total number of threads:     %s, average %s per thread\n",

    $formatter->format_number($count),

    $formatter->format_bytes( $totsize / $count,

    ( 'precision' => 1, 'mode' => 'iec' ) );

  printf __"Total number of user agents: %d\n",

    $formatter->format_number( scalar keys %agents );

  print "\n", "=" x 76, "\n";

  ########################################

  ## Show posters by article count  Sec 1;

  ########################################

  unless ( $skipSec{1} )

  {

    if ( keys %data < $topposters )

    {

      $count = keys %data;

    }

    else

    {

      $count = $topposters;

    }

    printf "%s\n",

      centred(

      __x( "Top {count} posters by number of articles", count => $topposters ),

      76

      );

    print "=" x 76, "\n";

    my $i = 0;

    foreach

      my $poster ( sort { $data{$b}{count} <=> $data{$a}{count} } keys %data )

    {

      my $name = substr( $poster, 0, 65 );

      printf "%2d. %-63s : %6d\n", $i + 1, rpad( $poster, 63, "." ),

        $data{$poster}{count};

      last if ( ++$i == $count );

    }

    print "\n", "=" x 76, "\n";