NewsStats.pm

   1 # NewsStats.pm
   2 #
   3 # Library functions for the NewsStats package.
   4 #
   5 # Copyright (c) 2010 Thomas Hochstein <thh@inter.net>
   6 #
   7 # This module can be redistributed and/or modified under the same terms under
   8 # which Perl itself is published.
   9
  10 package NewsStats;
  11
  12 use strict;
  13 use warnings;
  14 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  15
  16 require Exporter;
  17 @ISA = qw(Exporter);
  18 @EXPORT = qw(
  19   $MySelf
  20   $MyVersion
  21   ReadOptions
  22   ReadConfig
  23   OverrideConfig
  24   InitDB
  25 );
  26 @EXPORT_OK = qw(
  27   GetTimePeriod
  28   LastMonth
  29   CheckMonth
  30   SplitPeriod
  31   ListMonth
  32   ListNewsgroups
  33   OutputData
  34   FormatOutput
  35   SQLHierarchies
  36   SQLGroupList
  37   GetMaxLenght
  38 );
  39 %EXPORT_TAGS = ( TimePeriods => [qw(GetTimePeriod LastMonth CheckMonth SplitPeriod ListMonth)],
  40                  Output      => [qw(OutputData FormatOutput)],
  41                  SQLHelper   => [qw(SQLHierarchies SQLGroupList GetMaxLenght)]);
  42 $VERSION = '0.1';
  43
  44 use Data::Dumper;
  45 use File::Basename;
  46 use Getopt::Std;
  47
  48 use Config::Auto;
  49 use DBI;
  50
  51 #####-------------------------------- Vars --------------------------------#####
  52
  53 our $MySelf = fileparse($0, '.pl');
  54 our $MyVersion = "$MySelf $::VERSION (NewsStats.pm $VERSION)";
  55
  56 #####------------------------------- Basics -------------------------------#####
  57
  58 ################################################################################
  59 sub ReadOptions {
  60 ################################################################################
  61 ### read commandline options and act on standard options
  62 ### IN : $Params: containing list of commandline paramaters (without -h and -V)
  63 ### OUT: a hash containing the commandline options
  64   $Getopt::Std::STANDARD_HELP_VERSION = 1;
  65
  66   my ($Params) = @_;
  67   my %Options;
  68
  69   getopts('Vh'.$Params, \%Options);
  70
  71   # -V: display version
  72   &ShowVersion if ($Options{'V'});
  73
  74   # -h: feed myself to perldoc
  75   &ShowPOD if ($Options{'h'});
  76
  77   return %Options;
  78 };
  79 ################################################################################
  80
  81 ################################################################################
  82 sub ShowVersion {
  83 ################################################################################
  84 ### display version and exit
  85   print "$MyVersion\nCopyright (c) 2010 Thomas Hochstein <thh\@inter.net>\n";
  86   print "This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself.\n";
  87   exit(100);
  88 };
  89 ################################################################################
  90
  91 ################################################################################
  92 sub ShowPOD {
  93 ################################################################################
  94 ### feed myself to perldoc and exit
  95   exec('perldoc', $0);
  96   exit(100);
  97 };
  98 ################################################################################
  99
 100 ################################################################################
 101 sub ReadConfig {
 102 ################################################################################
 103 ### read config via Config::Auto
 104 ### IN : $ConfFile: config filename
 105 ### OUT: reference to a hash containing the configuration
 106   my ($ConfFile) = @_;
 107   return Config::Auto::parse($ConfFile, format => 'equal');
 108 };
 109 ################################################################################
 110
 111 ################################################################################
 112 sub OverrideConfig  {
 113 ################################################################################
 114 ### override configuration values
 115 ### IN : $ConfigR  : reference to configuration hash
 116 ###      $OverrideR: reference to a hash containing overrides
 117   my ($ConfigR,$OverrideR) = @_;
 118   my %Override = %$OverrideR;
 119   warn "$MySelf W: Empty configuration hash passed to OverrideConfig().\n" if ( keys %$ConfigR < 1);
 120   return if (keys %Override < 1 or keys %$ConfigR < 1);
 121   foreach my $Key (keys %Override) {
 122     $$ConfigR{$Key} = $Override{$Key};
 123   };
 124 };
 125 ################################################################################
 126
 127 ################################################################################
 128 sub InitDB {
 129 ################################################################################
 130 ### initialise database connection
 131 ### IN : $ConfigR: reference to configuration hash
 132 ###      $Die    : if TRUE, die if connection failed
 133 ### OUT: DBHandle
 134   my ($ConfigR,$Die) = @_;
 135   my %Conf = %$ConfigR;
 136   my $DBHandle = DBI->connect(sprintf('DBI:%s:database=%s;host=%s',$Conf{'DBDriver'},$Conf{'DBDatabase'},$Conf{'DBHost'}), $Conf{'DBUser'}, $Conf{'DBPw'}, { PrintError => 0 });
 137   if (!$DBHandle) {
 138     die ("$MySelf: E: $DBI::errstr\n") if (defined($Die) and $Die);
 139     warn("$MySelf: W: $DBI::errstr\n");
 140   };
 141   return $DBHandle;
 142 };
 143 ################################################################################
 144
 145 #####------------------------------ GetStats ------------------------------#####
 146
 147 ################################################################################
 148 sub ListNewsgroups {
 149 ################################################################################
 150 ### count each newsgroup and each hierarchy level, but only once
 151 ### IN : $Newsgroups: a list of newsgroups (content of Newsgroups:)
 152 ### OUT: %Newsgroups: hash containing all newsgroup and hierarchy names as keys
 153   my ($Newsgroups) = @_;
 154   my %Newsgroups;
 155   chomp($Newsgroups);
 156   # remove whitespace from contents of Newsgroups:
 157   $Newsgroups =~ s/\s//;
 158   # call &HierarchyCount for each newsgroup in $Newsgroups:
 159   for (split /,/, $Newsgroups) {
 160     # add original newsgroup to %Newsgroups
 161     $Newsgroups{$_} = 1;
 162     # add all hierarchy elements to %Newsgroups, amended by '.ALL',
 163     # i.e. de.alt.ALL and de.ALL
 164     foreach (ParseHierarchies($_)) {
 165       $Newsgroups{$_.'.ALL'} = 1;
 166     }
 167   };
 168   return %Newsgroups;
 169 };
 170
 171 ################################################################################
 172 sub ParseHierarchies {
 173 ################################################################################
 174 ### get all hierarchies a newsgroup belongs to
 175 ### IN : $Newsgroup  : a newsgroup name
 176 ### OUT: @Hierarchies: array containing all hierarchies the newsgroup belongs to
 177   my ($Newsgroup) = @_;
 178   my @Hierarchies;
 179   # strip trailing dots
 180   $Newsgroup =~ s/(.+)\.+$/$1/;
 181   # butcher newsgroup name by "." and add each hierarchy to @Hierarchies
 182   # i.e. de.alt.test: "de.alt" and "de"
 183   while ($Newsgroup =~ /\./) {
 184     $Newsgroup =~ s/^((?:\.?[^.]+)*)\.[^.]+$/$1/;
 185     push @Hierarchies, $Newsgroup;
 186   };
 187   return @Hierarchies;
 188 };
 189
 190 ################################################################################
 191
 192 #####----------------------------- TimePeriods ----------------------------#####
 193
 194 ################################################################################
 195 sub GetTimePeriod {
 196 ################################################################################
 197 ### get time period using -m / -p
 198 ### IN : $Month,$Period: contents of -m and -p
 199 ### OUT: $StartMonth, $EndMonth
 200   my ($Month,$Period) = @_;
 201   # exit if -m is set and not like YYYY-MM
 202   die "$MySelf: E: Wrong date format - use '$MySelf -m YYYY-MM'!\n" if not &CheckMonth($Month);
 203   # warn if -m and -p is set
 204   warn "$MySelf: W: Time period assigned by '-p' takes precendece over month assigned by '-m'.\n" if ($Month && $Period);
 205   # default: set -m to last month
 206   $Month = &LastMonth if (!defined($Month) and !defined($Period));
 207   # set $StartMonth, $EndMonth
 208   my ($StartMonth, $EndMonth);
 209   if ($Period) {
 210     # -p: get date range
 211     ($StartMonth, $EndMonth) = &SplitPeriod($Period);
 212     die "$MySelf: E: Wrong format for time period - use '$MySelf -p YYYY-MM:YYYY-MM'!\n" if !defined($StartMonth);
 213   } else {
 214     # set $StartMonth = $EndMonth = $Month if -p is not set
 215     $StartMonth = $EndMonth = $Month;
 216   };
 217   return ($StartMonth, $EndMonth);
 218 };
 219
 220 ################################################################################
 221 sub LastMonth {
 222 ################################################################################
 223 ### get last month from today in YYYY-MM format
 224 ### OUT: last month as YYYY-MM
 225   # get today's date
 226   my (undef,undef,undef,undef,$Month,$Year,undef,undef,undef) = localtime(time);
 227   # $Month is already defined from 0 to 11, so no need to decrease it by 1
 228   $Year += 1900;
 229   if ($Month < 1) {
 230     $Month = 12;
 231     $Year--;
 232   };
 233   # return last month
 234   return sprintf('%4d-%02d',$Year,$Month);
 235 };
 236
 237 ################################################################################
 238 sub CheckMonth {
 239 ################################################################################
 240 ### check for valid month
 241 ### IN : $Month: month
 242 ### OUT: TRUE / FALSE
 243   my ($Month) = @_;
 244   return 0 if (defined($Month) and $Month !~ /^\d{4}-\d{2}$/);
 245   return 1;
 246 };
 247
 248 ################################################################################
 249 sub SplitPeriod {
 250 ################################################################################
 251 ### split a time period YYYY-MM:YYYY-MM into start and end month
 252 ### IN : $Period: time period
 253 ### OUT: $StartMonth, Â$EndMonth
 254   my ($Period) = @_;
 255   return (undef,undef) if $Period !~ /^\d{4}-\d{2}:\d{4}-\d{2}$/;
 256   my ($StartMonth, $EndMonth) = split /:/, $Period;
 257   # switch parameters as necessary
 258   if ($EndMonth gt $StartMonth) {
 259     return ($StartMonth, $EndMonth);
 260   } else {
 261     return ($EndMonth, $StartMonth);
 262   };
 263 };
 264
 265 ################################################################################
 266 sub ListMonth {
 267 ################################################################################
 268 ### return a list of month (YYYY-MM) between start and end month
 269 ### IN : $StartMonth, $EndMonth
 270 ### OUT: @Months: array containing all months from $StartMonth to $EndMonth
 271   my ($StartMonth, $EndMonth) = @_;
 272   return (undef,undef) if ($StartMonth !~ /^\d{4}-\d{2}$/ or $EndMonth !~ /^\d{4}-\d{2}$/);
 273   # return if $StartMonth = $EndMonth
 274   return ($StartMonth) if ($StartMonth eq $EndMonth);
 275   # set $Year, $Month from $StartMonth
 276   my ($Year, $Month) = split /-/, $StartMonth;
 277   # define @Months
 278   my (@Months);
 279   until ("$Year-$Month" gt $EndMonth) {
 280     push @Months, "$Year-$Month";
 281     $Month = "$Month"; # force string context
 282     $Month++;
 283     if ($Month > 12) {
 284       $Month = '01';
 285       $Year++;
 286     };
 287   };
 288   return @Months;
 289 };
 290
 291 #####---------------------------- OutputFormats ---------------------------#####
 292
 293 ################################################################################
 294 sub OutputData {
 295 ################################################################################
 296 ### output information with formatting from DBHandle
 297 ### IN : $Format : format specifier
 298 ###      $DBQuery: database query handle with executed query,
 299 ###                containing $Month, $Key, $Value
 300 ###      $PadGroup: padding length for newsgroups field (optional) for 'pretty'
 301 ### OUT: $Output: formatted output
 302   my ($Format, $DBQuery,$PadGroup) = @_;
 303   while (my ($Month, $Key, $Value) = $DBQuery->fetchrow_array) {
 304     print &FormatOutput($Format, $Month, $Key, $Value, $PadGroup);
 305   };
 306 };
 307
 308 ################################################################################
 309 sub FormatOutput {
 310 ################################################################################
 311 ### format information for output
 312 ### IN : $Format  : format specifier
 313 ###      $PadGroup: padding length for newsgroups field (optional) for 'pretty'
 314 ###      $Month   : month (as YYYY-MM)
 315 ###      $Key     : newsgroup, client, ...
 316 ###      $Value   : number of postings with that attribute
 317 ### OUT: $Output: formatted output
 318   my ($Format, $Month, $Key, $Value, $PadGroup) = @_;
 319
 320   # define output types
 321   my %LegalOutput;
 322   @LegalOutput{('dump','dumpgroup','list','pretty')} = ();
 323   # bail out if format is unknown
 324   die "$MySelf: E: Unknown output type '$Format'!\n" if !exists($LegalOutput{$Format});
 325
 326   my ($Output);
 327   our ($LastIteration);
 328   if ($Format eq 'dump') {
 329     # output as dump (ng nnnnn)
 330     $Output = sprintf ("%s %u\n",$Key,$Value);
 331   } elsif ($Format eq 'dumpgroup') {
 332     # output as dump (YYYY-NN: nnnnn)
 333     $Output = sprintf ("%s: %5u\n",$Month,$Value);
 334   } elsif ($Format eq 'list') {
 335     # output as list (YYYY-NN: ng nnnnn)
 336     $Output = sprintf ("%s: %s %u\n",$Month,$Key,$Value);
 337   } elsif ($Format eq 'pretty') {
 338     # output as table
 339     $Output = sprintf ("----- %s:\n",$Month) if (!defined($LastIteration) or $Month ne $LastIteration);
 340     $LastIteration = $Month;
 341     $Output .= sprintf ($PadGroup ? sprintf("%%-%us %%5u\n",$PadGroup) : "%s %u\n",$Key,$Value);
 342   };
 343   return $Output;
 344 };
 345
 346 #####------------------------- QueryModifications -------------------------#####
 347
 348 ################################################################################
 349 sub SQLHierarchies {
 350 ################################################################################
 351 ### amend WHERE clause to include hierarchies
 352 ### IN : $ShowHierarchies: boolean value
 353 ### OUT: SQL code
 354   my ($ShowHierarchies) = @_;
 355   return $ShowHierarchies ? '' : "AND newsgroup NOT LIKE '%.ALL'";
 356 };
 357
 358 ################################################################################
 359 sub GetMaxLenght {
 360 ################################################################################
 361 ### get length of longest field in query
 362 ### IN : $DBHandle   : database handel
 363 ###      $Table      : table to query
 364 ###      $Field      : field to check
 365 ###      $WhereClause: WHERE clause
 366 ###      @BindVars   : bind variables for WHERE clause
 367 ### OUT: $Length: length of longest instnace of $Field
 368   my ($DBHandle,$Table,$Field,$WhereClause,@BindVars) = @_;
 369   my $DBQuery = $DBHandle->prepare(sprintf("SELECT MAX(LENGTH(%s)) FROM %s WHERE %s",$Field,$Table,$WhereClause));
 370   $DBQuery->execute(@BindVars) or warn sprintf("$MySelf: W: Can't get field length for %s from table %s: $DBI::errstr\n",$Field,$Table);
 371   my ($Length) = $DBQuery->fetchrow_array;
 372   return $Length;
 373 };
 374
 375 ################################################################################
 376 sub SQLGroupList {
 377 ################################################################################
 378 ### create part of WHERE clause for list of newsgroups separated by :
 379 ### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*)
 380 ### OUT: SQL code, list of newsgroups
 381   my ($Newsgroups) = @_;
 382   $Newsgroups =~ s/\*/%/g;
 383   return ('newsgroup LIKE ?', $Newsgroups) if $Newsgroups !~ /:/;
 384   my $SQL = '(';
 385   my @GroupList = split /:/, $Newsgroups;
 386   foreach (@GroupList) {
 387      $SQL .= ' OR ' if $SQL gt '(';
 388      $SQL .= 'newsgroup LIKE ?';
 389   };
 390   $SQL .= ')';
 391   return ($SQL,@GroupList);
 392 };
 393
 394 #####------------------------------- done ---------------------------------#####
 395 1;
 396
 397