Add comments and POD.
[usenet/newsstats.git] / 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 -h and -V
62 ### IN : $Params: list of legal 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   # Config hash empty?
120   warn "$MySelf W: Empty configuration hash passed to OverrideConfig().\n" if ( keys %$ConfigR < 1);
121   # return if no overrides
122   return if (keys %Override < 1 or keys %$ConfigR < 1);
123   foreach my $Key (keys %Override) {
124     $$ConfigR{$Key} = $Override{$Key};
125   };
126 };
127 ################################################################################
128
129 ################################################################################
130 sub InitDB {
131 ################################################################################
132 ### initialise database connection
133 ### IN : $ConfigR: reference to configuration hash
134 ###      $Die    : if TRUE, die if connection fails
135 ### OUT: DBHandle
136   my ($ConfigR,$Die) = @_;
137   my %Conf = %$ConfigR;
138   my $DBHandle = DBI->connect(sprintf('DBI:%s:database=%s;host=%s',$Conf{'DBDriver'},$Conf{'DBDatabase'},$Conf{'DBHost'}), $Conf{'DBUser'}, $Conf{'DBPw'}, { PrintError => 0 });
139   if (!$DBHandle) {
140     die ("$MySelf: E: $DBI::errstr\n") if (defined($Die) and $Die);
141     warn("$MySelf: W: $DBI::errstr\n");
142   };
143   return $DBHandle;
144 };
145 ################################################################################
146
147 #####------------------------------ GetStats ------------------------------#####
148
149 ################################################################################
150 sub ListNewsgroups {
151 ################################################################################
152 ### explode a (scalar) list of newsgroup names to a list of newsgroup and
153 ### hierarchy names where every newsgroup and hierarchy appears only once:
154 ### de.alt.test,de.alt.admin -> de.ALL, de.alt.ALL, de.alt.test, de.alt.admin
155 ### IN : $Newsgroups: a list of newsgroups (content of Newsgroups: header)
156 ### OUT: %Newsgroups: hash containing all newsgroup and hierarchy names as keys
157   my ($Newsgroups) = @_;
158   my %Newsgroups;
159   chomp($Newsgroups);
160   # remove whitespace from contents of Newsgroups:
161   $Newsgroups =~ s/\s//;
162   # call &HierarchyCount for each newsgroup in $Newsgroups:
163   for (split /,/, $Newsgroups) {
164     # add original newsgroup to %Newsgroups
165     $Newsgroups{$_} = 1;
166     # add all hierarchy elements to %Newsgroups, amended by '.ALL',
167     # i.e. de.alt.ALL and de.ALL
168     foreach (ParseHierarchies($_)) {
169       $Newsgroups{$_.'.ALL'} = 1;
170     }
171   };
172   return %Newsgroups;
173 };
174
175 ################################################################################
176 sub ParseHierarchies {
177 ################################################################################
178 ### return a list of all hierarchy levels a newsgroup belongs to
179 ### (for de.alt.test.moderated that would be de/de.alt/de.alt.test)
180 ### IN : $Newsgroup  : a newsgroup name
181 ### OUT: @Hierarchies: array containing all hierarchies the newsgroup belongs to
182   my ($Newsgroup) = @_;
183   my @Hierarchies;
184   # strip trailing dots
185   $Newsgroup =~ s/(.+)\.+$/$1/;
186   # butcher newsgroup name by "." and add each hierarchy to @Hierarchies
187   # i.e. de.alt.test: "de.alt" and "de"
188   while ($Newsgroup =~ /\./) {
189     $Newsgroup =~ s/^((?:\.?[^.]+)*)\.[^.]+$/$1/;
190     push @Hierarchies, $Newsgroup;
191   };
192   return @Hierarchies;
193 };
194
195 ################################################################################
196
197 #####----------------------------- TimePeriods ----------------------------#####
198
199 ################################################################################
200 sub GetTimePeriod {
201 ################################################################################
202 ### get a time period to act on, in order of preference: by default the
203 ### last month; or a month submitted by -m YYYY-MM; or a time period submitted
204 ### by -p YYYY-MM:YYYY-MM
205 ### IN : $Month,$Period: contents of -m and -p
206 ### OUT: $StartMonth, $EndMonth (identical if period is just one month)
207   my ($Month,$Period) = @_;
208   # exit if -m is set and not like YYYY-MM
209   die "$MySelf: E: Wrong date format - use '$MySelf -m YYYY-MM'!\n" if not &CheckMonth($Month);
210   # warn if -m and -p is set
211   warn "$MySelf: W: Time period assigned by '-p' takes precendece over month assigned by '-m'.\n" if ($Month && $Period);
212   # default: set -m to last month
213   $Month = &LastMonth if (!defined($Month) and !defined($Period));
214   # set $StartMonth, $EndMonth
215   my ($StartMonth, $EndMonth);
216   if ($Period) {
217     # -p: get date range
218     ($StartMonth, $EndMonth) = &SplitPeriod($Period);
219     die "$MySelf: E: Wrong format for time period - use '$MySelf -p YYYY-MM:YYYY-MM'!\n" if !defined($StartMonth);
220   } else {
221     # set $StartMonth = $EndMonth = $Month if -p is not set
222     $StartMonth = $EndMonth = $Month;
223   };
224   return ($StartMonth, $EndMonth);
225 };
226
227 ################################################################################
228 sub LastMonth {
229 ################################################################################
230 ### get last month from todays date in YYYY-MM format
231 ### OUT: last month as YYYY-MM
232   # get today's date
233   my (undef,undef,undef,undef,$Month,$Year,undef,undef,undef) = localtime(time);
234   # $Month is already defined from 0 to 11, so no need to decrease it by 1
235   $Year += 1900;
236   if ($Month < 1) {
237     $Month = 12;
238     $Year--;
239   };
240   # return last month
241   return sprintf('%4d-%02d',$Year,$Month);
242 };
243
244 ################################################################################
245 sub CheckMonth {
246 ################################################################################
247 ### check if input is a valid month in YYYY-MM form
248 ### IN : $Month: month
249 ### OUT: TRUE / FALSE
250   my ($Month) = @_;
251   return 0 if (defined($Month) and $Month !~ /^\d{4}-\d{2}$/);
252   return 1;
253 };
254
255 ################################################################################
256 sub SplitPeriod {
257 ################################################################################
258 ### split a time period denoted by YYYY-MM:YYYY-MM into start and end month
259 ### IN : $Period: time period
260 ### OUT: $StartMonth, Â$EndMonth
261   my ($Period) = @_;
262   return (undef,undef) if $Period !~ /^\d{4}-\d{2}:\d{4}-\d{2}$/;
263   my ($StartMonth, $EndMonth) = split /:/, $Period;
264   # switch parameters as necessary
265   if ($EndMonth gt $StartMonth) {
266     return ($StartMonth, $EndMonth);
267   } else {
268     return ($EndMonth, $StartMonth);
269   };
270 };
271
272 ################################################################################
273 sub ListMonth {
274 ################################################################################
275 ### return a list of months (YYYY-MM) between start and end month
276 ### IN : $StartMonth, $EndMonth
277 ### OUT: @Months: array containing all months from $StartMonth to $EndMonth
278   my ($StartMonth, $EndMonth) = @_;
279   return (undef,undef) if ($StartMonth !~ /^\d{4}-\d{2}$/ or $EndMonth !~ /^\d{4}-\d{2}$/);
280   # return if $StartMonth = $EndMonth
281   return ($StartMonth) if ($StartMonth eq $EndMonth);
282   # set $Year, $Month from $StartMonth
283   my ($Year, $Month) = split /-/, $StartMonth;
284   # define @Months
285   my (@Months);
286   until ("$Year-$Month" gt $EndMonth) {
287     push @Months, "$Year-$Month";
288     $Month = "$Month"; # force string context
289     $Month++;
290     if ($Month > 12) {
291       $Month = '01';
292       $Year++;
293     };
294   };
295   return @Months;
296 };
297
298 #####---------------------------- OutputFormats ---------------------------#####
299
300 ################################################################################
301 sub OutputData {
302 ################################################################################
303 ### read database query results from DBHandle and print results with formatting
304 ### IN : $Format : format specifier
305 ###      $DBQuery: database query handle with executed query,
306 ###                containing $Month, $Key, $Value
307 ###      $PadGroup: padding length for newsgroups field (optional) for 'pretty'
308   my ($Format, $DBQuery,$PadGroup) = @_;
309   while (my ($Month, $Key, $Value) = $DBQuery->fetchrow_array) {
310     print &FormatOutput($Format, $Month, $Key, $Value, $PadGroup);
311   };
312 };
313
314 ################################################################################
315 sub FormatOutput {
316 ################################################################################
317 ### format information for output according to format specifier
318 ### IN : $Format  : format specifier
319 ###      $Month   : month (as YYYY-MM)
320 ###      $Key     : newsgroup, client, ...
321 ###      $Value   : number of postings with that attribute
322 ###      $PadGroup: padding length for key field (optional) for 'pretty'
323 ### OUT: $Output: formatted output
324   my ($Format, $Month, $Key, $Value, $PadGroup) = @_;
325
326   # define output types
327   my %LegalOutput;
328   @LegalOutput{('dump','dumpgroup','list','pretty')} = ();
329   # bail out if format is unknown
330   die "$MySelf: E: Unknown output type '$Format'!\n" if !exists($LegalOutput{$Format});
331
332   my ($Output);
333   # keep last month in mind
334   our ($LastIteration);
335   if ($Format eq 'dump') {
336     # output as dump (ng nnnnn)
337     $Output = sprintf ("%s %u\n",$Key,$Value);
338   } elsif ($Format eq 'dumpgroup') {
339     # output as dump (YYYY-NN: nnnnn)
340     $Output = sprintf ("%s: %5u\n",$Month,$Value);
341   } elsif ($Format eq 'list') {
342     # output as list (YYYY-NN: ng nnnnn)
343     $Output = sprintf ("%s: %s %u\n",$Month,$Key,$Value);
344   } elsif ($Format eq 'pretty') {
345     # output as table
346     $Output = sprintf ("----- %s:\n",$Month) if (!defined($LastIteration) or $Month ne $LastIteration);
347     $LastIteration = $Month;
348     $Output .= sprintf ($PadGroup ? sprintf("%%-%us %%5u\n",$PadGroup) : "%s %u\n",$Key,$Value);
349   };
350   return $Output;
351 };
352
353 #####------------------------- QueryModifications -------------------------#####
354
355 ################################################################################
356 sub SQLHierarchies {
357 ################################################################################
358 ### add exclusion of hierarchy levels (de.alt.ALL) from SQL query by
359 ### amending the WHERE clause if $ShowHierarchies is false (or don't, if it is
360 ### true, accordingly)
361 ### IN : $ShowHierarchies: boolean value
362 ### OUT: SQL code
363   my ($ShowHierarchies) = @_;
364   return $ShowHierarchies ? '' : "AND newsgroup NOT LIKE '%.ALL'";
365 };
366
367 ################################################################################
368 sub GetMaxLenght {
369 ################################################################################
370 ### get length of longest field in future query result
371 ### IN : $DBHandle   : database handel
372 ###      $Table      : table to query
373 ###      $Field      : field to check
374 ###      $WhereClause: WHERE clause
375 ###      @BindVars   : bind variables for WHERE clause
376 ### OUT: $Length: length of longest instnace of $Field
377   my ($DBHandle,$Table,$Field,$WhereClause,@BindVars) = @_;
378   my $DBQuery = $DBHandle->prepare(sprintf("SELECT MAX(LENGTH(%s)) FROM %s WHERE %s",$Field,$Table,$WhereClause));
379   $DBQuery->execute(@BindVars) or warn sprintf("$MySelf: W: Can't get field length for %s from table %s: $DBI::errstr\n",$Field,$Table);
380   my ($Length) = $DBQuery->fetchrow_array;
381   return $Length;
382 };
383
384 ################################################################################
385 sub SQLGroupList {
386 ################################################################################
387 ### explode list of newsgroups separated by : (with wildcards) to a SQL WHERE
388 ### clause
389 ### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*)
390 ### OUT: SQL code, list of newsgroups
391   my ($Newsgroups) = @_;
392   $Newsgroups =~ s/\*/%/g;
393   return ('newsgroup LIKE ?', $Newsgroups) if $Newsgroups !~ /:/;
394   my $SQL = '(';
395   my @GroupList = split /:/, $Newsgroups;
396   foreach (@GroupList) {
397      $SQL .= ' OR ' if $SQL gt '(';
398      $SQL .= 'newsgroup LIKE ?';
399   };
400   $SQL .= ')';
401   return ($SQL,@GroupList);
402 };
403
404 #####------------------------------- done ---------------------------------#####
405 1;
406
407
This page took 0.020689 seconds and 3 git commands to generate.