projects / usenet / newsstats.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Small comment fixes.
[usenet/newsstats.git] / lib / NewsStats.pm
CommitLineData
741336c2
TH		 1# NewsStats.pm
2#
3# Library functions for the NewsStats package.
4#
07c0b258 5# Copyright (c) 2010-2013 Thomas Hochstein <thh@inter.net>
741336c2 6#
8dc6823e 7# This module can be redistributed and/or modified under the same terms under
741336c2
TH		 8# which Perl itself is published.
9
10package NewsStats;
11
12use strict;
13use warnings;
14our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
15
16require Exporter;
17@ISA = qw(Exporter);
18@EXPORT = qw(
741336c2 19 $MyVersion
f6d15ca7 20 $PackageVersion
edd250f2
TH		 21 $FullPath
22 $HomePath
23 ShowVersion
24 ShowPOD
741336c2
TH		 25 ReadConfig
26 OverrideConfig
27 InitDB
edd250f2 28 Bleat
741336c2
TH		 29);
30@EXPORT_OK = qw(
31 GetTimePeriod
32 LastMonth
741336c2
TH		 33 SplitPeriod
34 ListMonth
35 ListNewsgroups
1703b8e3 36 ParseHierarchies
ad609792 37 ReadGroupList
741336c2
TH		 38 OutputData
39 FormatOutput
40 SQLHierarchies
edd250f2 41 SQLSortOrder
741336c2 42 SQLGroupList
edd250f2
TH		 43 SQLSetBounds
44 SQLBuildClause
d3b6810d 45 GetMaxLength
741336c2 46);
edd250f2
TH		 47%EXPORT_TAGS = ( TimePeriods => [qw(GetTimePeriod LastMonth SplitPeriod
48 ListMonth)],
741336c2 49 Output => [qw(OutputData FormatOutput)],
edd250f2
TH		 50 SQLHelper => [qw(SQLHierarchies SQLSortOrder SQLGroupList
51 SQLSetBounds SQLBuildClause GetMaxLength)]);
4bbd46d3
TH		 52$VERSION = '0.01';
53our $PackageVersion = '0.01';
741336c2
TH		 54
55use Data::Dumper;
56use File::Basename;
2ad99c20 57use Cwd qw(realpath);
741336c2
TH		 58
59use Config::Auto;
60use DBI;
61
62#####-------------------------------- Vars --------------------------------#####
63
2ad99c20 64# save $0 in $FullPath
edd250f2 65our $FullPath = $0;
2ad99c20
TH		 66# strip filename and /bin or /install directory to create the $HomePath
67our $HomePath = dirname(realpath($0));
68$HomePath =~ s/\/(bin|install)//;
69# trim $0
edd250f2
TH		 70$0 =~ s%.*/%%;
71# set version string
72our $MyVersion = "$0 $::VERSION (NewsStats.pm $VERSION)";
741336c2
TH		 73
74#####------------------------------- Basics -------------------------------#####
75
741336c2
TH		 76################################################################################
77
78################################################################################
79sub ShowVersion {
80################################################################################
81### display version and exit
edd250f2
TH		 82 print "NewsStats v$PackageVersion\n$MyVersion\n";
83 print "Copyright (c) 2010-2012 Thomas Hochstein <thh\@inter.net>\n";
84 print "This program is free software; you may redistribute it ".
85 "and/or modify it under the same terms as Perl itself.\n";
741336c2
TH		 86 exit(100);
87};
88################################################################################
89
90################################################################################
91sub ShowPOD {
92################################################################################
93### feed myself to perldoc and exit
edd250f2 94 exec('perldoc', $FullPath);
741336c2
TH		 95 exit(100);
96};
97################################################################################
98
99################################################################################
100sub ReadConfig {
101################################################################################
102### read config via Config::Auto
103### IN : $ConfFile: config filename
104### OUT: reference to a hash containing the configuration
105 my ($ConfFile) = @_;
2ad99c20
TH		 106 # set default
107 $ConfFile = $HomePath . '/etc/newsstats.conf' if !$ConfFile;
db7696e5
TH		 108 # mandatory configuration options
109 my @Mandatory = ('DBDriver','DBHost','DBUser','DBPw','DBDatabase',
110 'DBTableRaw','DBTableGrps');
111 # read config via Config::Auto
112 my $ConfR = Config::Auto::parse($ConfFile, format => 'equal');
113 my %Conf = %{$ConfR};
114 # check for mandatory options
115 foreach (@Mandatory) {
116 &Bleat(2,sprintf("Mandatory configuration option %s is not set!",$_))
117 if (!defined($Conf{$_}));
118 }
119 # $Conf{'TLH'} is checked in gatherstats.pl
120 return $ConfR;
741336c2
TH		 121};
122################################################################################
123
124################################################################################
edd250f2 125sub OverrideConfig {
741336c2
TH		 126################################################################################
127### override configuration values
128### IN : $ConfigR : reference to configuration hash
129### $OverrideR: reference to a hash containing overrides
130 my ($ConfigR,$OverrideR) = @_;
131 my %Override = %$OverrideR;
3430c898 132 # Config hash empty?
edd250f2
TH		 133 &Bleat(1,"Empty configuration hash passed to OverrideConfig()")
134 if ( keys %$ConfigR < 1);
3430c898 135 # return if no overrides
741336c2
TH		 136 return if (keys %Override < 1 or keys %$ConfigR < 1);
137 foreach my $Key (keys %Override) {
138 $$ConfigR{$Key} = $Override{$Key};
139 };
140};
141################################################################################
142
143################################################################################
144sub InitDB {
145################################################################################
146### initialise database connection
147### IN : $ConfigR: reference to configuration hash
3430c898 148### $Die : if TRUE, die if connection fails
741336c2
TH		 149### OUT: DBHandle
150 my ($ConfigR,$Die) = @_;
151 my %Conf = %$ConfigR;
edd250f2
TH		 152 my $DBHandle = DBI->connect(sprintf('DBI:%s:database=%s;host=%s',
153 $Conf{'DBDriver'},$Conf{'DBDatabase'},
154 $Conf{'DBHost'}), $Conf{'DBUser'},
155 $Conf{'DBPw'}, { PrintError => 0 });
741336c2 156 if (!$DBHandle) {
edd250f2
TH		 157 &Bleat(2,$DBI::errstr) if (defined($Die) and $Die);
158 &Bleat(1,$DBI::errstr);
741336c2
TH		 159 };
160 return $DBHandle;
161};
162################################################################################
163
edd250f2
TH		 164################################################################################
165sub Bleat {
166################################################################################
167### print warning or error messages and terminate in case of error
168### IN : $Level : 1 = warning, 2 = error
169### $Message: warning or error message
170 my ($Level,$Message) = @_;
171 if ($Level == 1) {
172 warn "$0 W: $Message\n"
173 } elsif ($Level == 2) {
174 die "$0 E: $Message\n"
175 } else {
176 print "$0: $Message\n"
177 }
178};
179################################################################################
180
741336c2
TH		 181#####------------------------------ GetStats ------------------------------#####
182
183################################################################################
184sub ListNewsgroups {
185################################################################################
3430c898
TH		 186### explode a (scalar) list of newsgroup names to a list of newsgroup and
187### hierarchy names where every newsgroup and hierarchy appears only once:
188### de.alt.test,de.alt.admin -> de.ALL, de.alt.ALL, de.alt.test, de.alt.admin
ad609792 189### IN : $Newsgroups : a list of newsgroups (content of Newsgroups: header)
89db2f90 190### $TLH : top level hierarchy (all other newsgroups are ignored)
ad609792
TH		 191### $ValidGroupsR: reference to a hash containing all valid newsgroups
192### as keys
193### OUT: %Newsgroups : hash containing all newsgroup and hierarchy names as keys
89db2f90 194 my ($Newsgroups,$TLH,$ValidGroupsR) = @_;
ad609792 195 my %ValidGroups = %{$ValidGroupsR} if $ValidGroupsR;
741336c2
TH		 196 my %Newsgroups;
197 chomp($Newsgroups);
198 # remove whitespace from contents of Newsgroups:
199 $Newsgroups =~ s/\s//;
200 # call &HierarchyCount for each newsgroup in $Newsgroups:
201 for (split /,/, $Newsgroups) {
89db2f90
TH		 202 # don't count newsgroup/hierarchy in wrong TLH
203 next if($TLH and !/^$TLH/);
ad609792
TH		 204 # don't count invalid newsgroups
205 if(%ValidGroups and !defined($ValidGroups{$_})) {
0dc13b39 206 warn (sprintf("DROPPED: %s\n",$_));
ad609792
TH		 207 next;
208 }
741336c2
TH		 209 # add original newsgroup to %Newsgroups
210 $Newsgroups{$_} = 1;
211 # add all hierarchy elements to %Newsgroups, amended by '.ALL',
212 # i.e. de.alt.ALL and de.ALL
213 foreach (ParseHierarchies($_)) {
214 $Newsgroups{$_.'.ALL'} = 1;
215 }
216 };
217 return %Newsgroups;
218};
219
220################################################################################
221sub ParseHierarchies {
222################################################################################
3430c898
TH		 223### return a list of all hierarchy levels a newsgroup belongs to
224### (for de.alt.test.moderated that would be de/de.alt/de.alt.test)
741336c2
TH		 225### IN : $Newsgroup : a newsgroup name
226### OUT: @Hierarchies: array containing all hierarchies the newsgroup belongs to
227 my ($Newsgroup) = @_;
228 my @Hierarchies;
229 # strip trailing dots
230 $Newsgroup =~ s/(.+)\.+$/$1/;
231 # butcher newsgroup name by "." and add each hierarchy to @Hierarchies
232 # i.e. de.alt.test: "de.alt" and "de"
233 while ($Newsgroup =~ /\./) {
234 $Newsgroup =~ s/^((?:\.?[^.]+)*)\.[^.]+$/$1/;
235 push @Hierarchies, $Newsgroup;
236 };
237 return @Hierarchies;
238};
239
ad609792
TH		 240################################################################################
241sub ReadGroupList {
242################################################################################
243### read a list of valid newsgroups from file (each group on one line,
244### ignoring everything after the first whitespace and so accepting files
245### in checkgroups format as well as (parts of) an INN active file)
246### IN : $Filename : file to read
8dc6823e 247### OUT: \%ValidGroups: reference to a hash containing all valid newsgroups
ad609792
TH		 248 my ($Filename) = @_;
249 my %ValidGroups;
edd250f2 250 open (my $LIST,"<$Filename") or &Bleat(2,"Cannot read $Filename: $!");
ad609792 251 while (<$LIST>) {
7662b106 252 s/^\s*(\S+).*$/$1/;
ad609792 253 chomp;
7662b106 254 next if /^$/;
ad609792
TH		 255 $ValidGroups{$_} = '1';
256 };
257 close $LIST;
258 return \%ValidGroups;
259};
260
741336c2
TH		 261################################################################################
262
263#####----------------------------- TimePeriods ----------------------------#####
264
265################################################################################
266sub GetTimePeriod {
267################################################################################
edd250f2
TH		 268### get a time period to act on from --month option;
269### if empty, default to last month
270### IN : $Month: may be empty, 'YYYY-MM', 'YYYY-MM:YYYY-MM' or 'all'
271### OUT: $Verbal,$SQL: verbal description and WHERE-clause
272### of the chosen time period
273 my ($Month) = @_;
274 # define result variables
275 my ($Verbal, $SQL);
276 # define a regular expression for a month
277 my $REMonth = '\d{4}-\d{2}';
8dc6823e 278
edd250f2
TH		 279 # default to last month if option is not set
280 if(!$Month) {
281 $Month = &LastMonth;
282 }
8dc6823e 283
edd250f2
TH		 284 # check for valid input
285 if ($Month =~ /^$REMonth$/) {
286 # single month (YYYY-MM)
287 ($Month) = &CheckMonth($Month);
288 $Verbal = $Month;
289 $SQL = sprintf("month = '%s'",$Month);
290 } elsif ($Month =~ /^$REMonth:$REMonth$/) {
291 # time period (YYYY-MM:YYYY-MM)
292 $Verbal = sprintf('%s to %s',&SplitPeriod($Month));
293 $SQL = sprintf("month BETWEEN '%s' AND '%s'",&SplitPeriod($Month));
294 } elsif ($Month =~ /^all$/i) {
295 # special case: ALL
296 $Verbal = 'all time';
297 $SQL = '';
741336c2 298 } else {
edd250f2
TH		 299 # invalid input
300 return (undef,undef);
301 }
8dc6823e 302
edd250f2 303 return ($Verbal,$SQL);
741336c2
TH		 304};
305
306################################################################################
307sub LastMonth {
308################################################################################
3430c898 309### get last month from todays date in YYYY-MM format
741336c2
TH		 310### OUT: last month as YYYY-MM
311 # get today's date
312 my (undef,undef,undef,undef,$Month,$Year,undef,undef,undef) = localtime(time);
313 # $Month is already defined from 0 to 11, so no need to decrease it by 1
314 $Year += 1900;
315 if ($Month < 1) {
316 $Month = 12;
317 $Year--;
318 };
319 # return last month
320 return sprintf('%4d-%02d',$Year,$Month);
321};
322
323################################################################################
324sub CheckMonth {
325################################################################################
edd250f2
TH		 326### check if input (in YYYY-MM form) is valid with MM between 01 and 12;
327### otherwise, fix it
328### IN : @Month: array of month
329### OUT: @Month: a valid month
330 my (@Month) = @_;
331 foreach my $Month (@Month) {
332 my ($OldMonth) = $Month;
333 my ($CalMonth) = substr ($Month, -2);
334 if ($CalMonth < 1 or $CalMonth > 12) {
335 $CalMonth = '12' if $CalMonth > 12;
336 $CalMonth = '01' if $CalMonth < 1;
337 substr($Month, -2) = $CalMonth;
338 &Bleat(1,sprintf("'%s' is an invalid date (MM must be between '01' ".
339 "and '12'), set to '%s'.",$OldMonth,$Month));
340 }
341 }
342 return @Month;
741336c2
TH		 343};
344
345################################################################################
346sub SplitPeriod {
347################################################################################
3430c898 348### split a time period denoted by YYYY-MM:YYYY-MM into start and end month
741336c2 349### IN : $Period: time period
edd250f2 350### OUT: $StartMonth, $EndMonth
741336c2 351 my ($Period) = @_;
741336c2 352 my ($StartMonth, $EndMonth) = split /:/, $Period;
edd250f2 353 ($StartMonth,$EndMonth) = CheckMonth($StartMonth,$EndMonth);
741336c2
TH		 354 # switch parameters as necessary
355 if ($EndMonth gt $StartMonth) {
356 return ($StartMonth, $EndMonth);
357 } else {
358 return ($EndMonth, $StartMonth);
359 };
360};
361
362################################################################################
363sub ListMonth {
364################################################################################
3430c898 365### return a list of months (YYYY-MM) between start and end month
880c3eb2
TH		 366### IN : $MonthExpression ('YYYY-MM' or 'YYYY-MM to YYYY-MM')
367### OUT: @Months: array containing all months from $MonthExpression enumerated
368 my ($MonthExpression )= @_;
369 # return if single month
370 return ($MonthExpression) if ($MonthExpression =~ /^\d{4}-\d{2}$/);
371 # parse $MonthExpression
372 my ($StartMonth, $EndMonth) = split(' to ',$MonthExpression);
741336c2
TH		 373 # set $Year, $Month from $StartMonth
374 my ($Year, $Month) = split /-/, $StartMonth;
375 # define @Months
376 my (@Months);
377 until ("$Year-$Month" gt $EndMonth) {
378 push @Months, "$Year-$Month";
379 $Month = "$Month"; # force string context
380 $Month++;
381 if ($Month > 12) {
382 $Month = '01';
383 $Year++;
384 };
385 };
386 return @Months;
387};
388
389#####---------------------------- OutputFormats ---------------------------#####
390
391################################################################################
392sub OutputData {
393################################################################################
3430c898 394### read database query results from DBHandle and print results with formatting
edd250f2
TH		 395### IN : $Format : format specifier
396### $Comments : print or suppress all comments for machine-readable output
397### $GroupBy : primary sorting order (month or key)
398### $Precision: number of digits right of decimal point (0 or 2)
399### $ValidKeys: reference to a hash containing all valid keys
400### $FileTempl: file name template (--filetemplate): filetempl-YYYY-MM
401### $DBQuery : database query handle with executed query,
78389b28 402### containing $Month, $Key, $Value
b342fcf0
TH		 403### $PadField : padding length for key field (optional) for 'pretty'
404### $PadValue : padding length for value field (optional) for 'pretty'
edd250f2 405 my ($Format, $Comments, $GroupBy, $Precision, $ValidKeys, $FileTempl,
b342fcf0 406 $DBQuery, $PadField, $PadValue) = @_;
edd250f2
TH		 407 my %ValidKeys = %{$ValidKeys} if $ValidKeys;
408 my ($FileName, $Handle, $OUT);
78389b28 409 our $LastIteration;
8dc6823e 410
edd250f2
TH		 411 # define output types
412 my %LegalOutput;
b342fcf0 413 @LegalOutput{('dump','list','pretty')} = ();
edd250f2
TH		 414 # bail out if format is unknown
415 &Bleat(2,"Unknown output type '$Format'!") if !exists($LegalOutput{$Format});
416
741336c2 417 while (my ($Month, $Key, $Value) = $DBQuery->fetchrow_array) {
edd250f2
TH		 418 # don't display invalid keys
419 if(%ValidKeys and !defined($ValidKeys{$Key})) {
420 # FIXME
421 # &Bleat(1,sprintf("DROPPED: %s",$Key));
422 next;
423 };
424 # care for correct sorting order and abstract from month and keys:
425 # $Caption will be $Month or $Key, according to sorting order,
426 # and $Key will be $Key or $Month, respectively
427 my $Caption;
428 if ($GroupBy eq 'key') {
429 $Caption = $Key;
430 $Key = $Month;
431 } else {
432 $Caption = $Month;
433 }
78389b28 434 # set output file handle
edd250f2 435 if (!$FileTempl) {
78389b28 436 $Handle = *STDOUT{IO}; # set $Handle to a reference to STDOUT
edd250f2 437 } elsif (!defined($LastIteration) or $LastIteration ne $Caption) {
78389b28 438 close $OUT if ($LastIteration);
edd250f2
TH		 439 # safeguards for filename creation:
440 # replace potential problem characters with '_'
441 $FileName = sprintf('%s-%s',$FileTempl,$Caption);
8dc6823e 442 $FileName =~ s/[^a-zA-Z0-9_-]+/_/g;
edd250f2
TH		 443 open ($OUT,">$FileName")
444 or &Bleat(2,sprintf("Cannot open output file '%s': $!",
445 $FileName));
78389b28
TH		 446 $Handle = $OUT;
447 };
edd250f2 448 print $Handle &FormatOutput($Format, $Comments, $Caption, $Key, $Value,
b342fcf0 449 $Precision, $PadField, $PadValue);
edd250f2 450 $LastIteration = $Caption;
741336c2 451 };
edd250f2 452 close $OUT if ($FileTempl);
741336c2
TH		 453};
454
455################################################################################
456sub FormatOutput {
457################################################################################
3430c898 458### format information for output according to format specifier
edd250f2
TH		 459### IN : $Format : format specifier
460### $Comments : print or suppress all comments for machine-readable output
461### $Caption : month (as YYYY-MM) or $Key, according to sorting order
462### $Key : newsgroup, client, ... or $Month, as above
463### $Value : number of postings with that attribute
464### $Precision: number of digits right of decimal point (0 or 2)
b342fcf0
TH		 465### $PadField : padding length for key field (optional) for 'pretty'
466### $PadValue : padding length for value field (optional) for 'pretty'
741336c2 467### OUT: $Output: formatted output
b342fcf0
TH		 468 my ($Format, $Comments, $Caption, $Key, $Value, $Precision, $PadField,
469 $PadValue) = @_;
741336c2 470 my ($Output);
edd250f2 471 # keep last caption in mind
741336c2 472 our ($LastIteration);
edd250f2 473 # create one line of output
741336c2 474 if ($Format eq 'dump') {
edd250f2
TH		 475 # output as dump (key value)
476 $Output = sprintf ("# %s:\n",$Caption)
477 if ($Comments and (!defined($LastIteration) or $Caption ne $LastIteration));
478 $Output .= sprintf ("%s %u\n",$Key,$Value);
741336c2 479 } elsif ($Format eq 'list') {
edd250f2
TH		 480 # output as list (caption key value)
481 $Output = sprintf ("%s %s %u\n",$Caption,$Key,$Value);
741336c2 482 } elsif ($Format eq 'pretty') {
edd250f2
TH		 483 # output as a table
484 $Output = sprintf ("# ----- %s:\n",$Caption)
485 if ($Comments and (!defined($LastIteration) or $Caption ne $LastIteration));
b342fcf0
TH		 486 # increase $PadValue for numbers with decimal point
487 $PadValue += $Precision+1 if $Precision;
488 # add padding if $PadField is set; $PadValue HAS to be set then
489 $Output .= sprintf ($PadField ?
490 sprintf("%%-%us%%s %%%u.*f\n",$PadField,$PadValue) :
491 "%s%s %.*f\n",$Key,$Comments ? ':' : '',
492 $Precision,$Value);
741336c2
TH		 493 };
494 return $Output;
495};
496
497#####------------------------- QueryModifications -------------------------#####
498
499################################################################################
500sub SQLHierarchies {
501################################################################################
3430c898
TH		 502### add exclusion of hierarchy levels (de.alt.ALL) from SQL query by
503### amending the WHERE clause if $ShowHierarchies is false (or don't, if it is
504### true, accordingly)
741336c2
TH		 505### IN : $ShowHierarchies: boolean value
506### OUT: SQL code
507 my ($ShowHierarchies) = @_;
edd250f2 508 return $ShowHierarchies ? '' : "newsgroup NOT LIKE '%.ALL'";
741336c2
TH		 509};
510
511################################################################################
d3b6810d 512sub GetMaxLength {
741336c2 513################################################################################
b342fcf0
TH		 514### get length of longest fields in future query result
515### IN : $DBHandle : database handle
edd250f2 516### $Table : table to query
b342fcf0
TH		 517### $Field : field (key!, i.e. month, newsgroup, ...) to check
518### $Value : field (value!, i.e. postings) to check
edd250f2
TH		 519### $WhereClause : WHERE clause
520### $HavingClause: HAVING clause
521### @BindVars : bind variables for WHERE clause
b342fcf0
TH		 522### OUT: $FieldLength : length of longest instance of $Field
523### $ValueLength : length of longest instance of $Value
524 my ($DBHandle,$Table,$Field,$Value,$WhereClause,$HavingClause,@BindVars) = @_;
525 my $DBQuery = $DBHandle->prepare(sprintf("SELECT MAX(LENGTH(%s)),".
526 "MAX(%s) ".
527 "FROM %s %s %s",$Field,,$Value,
528 $Table,$WhereClause,$HavingClause ?
edd250f2
TH		 529 'GROUP BY newsgroup' . $HavingClause .
530 ' ORDER BY LENGTH(newsgroup) '.
531 'DESC LIMIT 1': ''));
532 $DBQuery->execute(@BindVars) or &Bleat(1,sprintf("Can't get field length ".
533 "for '%s' from table '%s': ".
534 "$DBI::errstr",$Field,$Table));
b342fcf0
TH		 535 my ($FieldLength,$ValueMax) = $DBQuery->fetchrow_array;
536 my $ValueLength = length($ValueMax) if ($ValueMax);
537 return ($FieldLength,$ValueLength);
741336c2
TH		 538};
539
edd250f2
TH		 540################################################################################
541sub SQLSortOrder {
542################################################################################
543### build a SQL 'ORDER BY' clause from $OptGroupBy (primary sorting) and
544### $OptOrderBy (secondary sorting), both ascending or descending;
545### descending sorting order is done by adding '-desc'
546### IN : $GroupBy: primary sort by 'month' (default) or 'newsgroups'
547### $OrderBy: secondary sort by month/newsgroups (default)
548### or number of 'postings'
549### OUT: a SQL ORDER BY clause
550 my ($GroupBy,$OrderBy) = @_;
551 my ($GroupSort,$OrderSort) = ('','');
552 # $GroupBy (primary sorting)
553 if (!$GroupBy) {
554 $GroupBy = 'month';
555 } else {
556 ($GroupBy, $GroupSort) = SQLParseOrder($GroupBy);
557 if ($GroupBy =~ /group/i) {
558 $GroupBy = 'newsgroup';
559 } else {
560 $GroupBy = 'month';
561 }
562 }
563 my $Secondary = ($GroupBy eq 'month') ? 'newsgroup' : 'month';
564 # $OrderBy (secondary sorting)
565 if (!$OrderBy) {
566 $OrderBy = $Secondary;
567 } else {
568 ($OrderBy, $OrderSort) = SQLParseOrder($OrderBy);
569 if ($OrderBy =~ /posting/i) {
570 $OrderBy = "postings $OrderSort, $Secondary";
571 } else {
572 $OrderBy = "$Secondary $OrderSort";
573 }
574 }
575 return ($GroupBy,&SQLBuildClause('order',"$GroupBy $GroupSort",$OrderBy));
576};
577
578################################################################################
579sub SQLParseOrder {
580################################################################################
581### parse $OptGroupBy or $OptOrderBy option of the form param[-desc], e.g.
582### 'month', 'month-desc', 'newsgroups-desc', but also just 'desc'
583### IN : $OrderOption: order option (see above)
584### OUT: parameter to sort by,
585### sort order ('DESC' or nothing, meaning 'ASC')
586 my ($OrderOption) = @_;
587 my $SortOrder = '';
588 if ($OrderOption =~ s/-?desc$//i) {
589 $SortOrder = 'DESC';
590 } else {
591 $OrderOption =~ s/-?asc$//i
592 }
593 return ($OrderOption,$SortOrder);
594};
595
741336c2
TH		 596################################################################################
597sub SQLGroupList {
598################################################################################
edd250f2
TH		 599### explode list of newsgroups separated by : (with wildcards)
600### to a SQL 'WHERE' expression
741336c2 601### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*)
edd250f2
TH		 602### OUT: SQL code to become part of a 'WHERE' clause,
603### list of newsgroups for SQL bindings
741336c2 604 my ($Newsgroups) = @_;
edd250f2 605 # substitute '*' wildcard with SQL wildcard character '%'
741336c2 606 $Newsgroups =~ s/\*/%/g;
c30822b4 607 return (undef,undef) if !CheckValidNewsgroups($Newsgroups);
edd250f2
TH		 608 # just one newsgroup?
609 return (SQLGroupWildcard($Newsgroups),$Newsgroups) if $Newsgroups !~ /:/;
10459ac8 610 my ($SQL,@WildcardGroups,@NoWildcardGroups);
edd250f2 611 # list of newsgroups separated by ':'
741336c2
TH		 612 my @GroupList = split /:/, $Newsgroups;
613 foreach (@GroupList) {
10459ac8
TH		 614 if ($_ !~ /%/) {
615 # add to list of newsgroup names WITHOUT wildcard
616 push (@NoWildcardGroups,$_);
617 } else {
618 # add to list of newsgroup names WITH wildcard
619 push (@WildcardGroups,$_);
620 # add wildcard to SQL clause
621 # 'OR' if SQL clause is not empty
622 $SQL .= ' OR ' if $SQL;
623 $SQL .= 'newsgroup LIKE ?'
624 }
741336c2 625 };
10459ac8
TH		 626 if (scalar(@NoWildcardGroups)) {
627 # add 'OR' if SQL clause is not empty
628 $SQL .= ' OR ' if $SQL;
629 if (scalar(@NoWildcardGroups) < 2) {
630 # special case: just one newsgroup without wildcard
631 $SQL .= 'newsgroup = ?';
632 } else {
633 # create list of newsgroups to include: 'newsgroup IN (...)'
634 $SQL .= 'newsgroup IN (';
635 my $SQLin;
636 foreach (@NoWildcardGroups) {
637 $SQLin .= ',' if $SQLin;
638 $SQLin .= '?';
639 }
640 # add list to SQL clause
641 $SQL .= $SQLin .= ')';
642 }
643 }
644 # add brackets '()' to SQL clause as needed (more than one wildcard group)
645 if (scalar(@WildcardGroups)) {
646 $SQL = '(' . $SQL .')';
647 }
648 # rebuild @GroupList in (now) correct order
649 @GroupList = (@WildcardGroups,@NoWildcardGroups);
741336c2
TH		 650 return ($SQL,@GroupList);
651};
652
edd250f2
TH		 653################################################################################
654sub SQLGroupWildcard {
655################################################################################
656### build a valid SQL 'WHERE' expression with or without wildcards
657### IN : $Newsgroup: newsgroup expression, probably with wildcard
658### (group.name or group.name.%)
659### OUT: SQL code to become part of a 'WHERE' clause
660 my ($Newsgroup) = @_;
edd250f2
TH		 661 if ($Newsgroup !~ /%/) {
662 return 'newsgroup = ?';
663 } else {
664 return 'newsgroup LIKE ?';
665 }
666};
667
668################################################################################
669sub SQLSetBounds {
670################################################################################
671### set upper and/or lower boundary (number of postings)
672### IN : $Type: 'level', 'average', 'sum' or 'default'
673### $LowBound,$UppBound: lower/upper boundary, respectively
674### OUT: SQL code to become part of a WHERE or HAVING clause
675 my ($Type,$LowBound,$UppBound) = @_;
676 ($LowBound,$UppBound) = SQLCheckNumber($LowBound,$UppBound);
677 if($LowBound and $UppBound and $LowBound > $UppBound) {
678 &Bleat(1,"Lower boundary $LowBound is larger than Upper boundary ".
679 "$UppBound, exchanging boundaries.");
680 ($LowBound,$UppBound) = ($UppBound,$LowBound);
681 }
682 # default to 'default'
683 my $WhereHavingFunction = 'postings';
684 # set $LowBound to SQL statement:
685 # 'WHERE postings >=', 'HAVING MIN(postings) >=' or 'HAVING AVG(postings) >='
686 if ($Type eq 'level') {
687 $WhereHavingFunction = 'MIN(postings)'
688 } elsif ($Type eq 'average') {
689 $WhereHavingFunction = 'AVG(postings)'
690 } elsif ($Type eq 'sum') {
691 $WhereHavingFunction = 'SUM(postings)'
692 }
693 $LowBound = sprintf('%s >= '.$LowBound,$WhereHavingFunction) if ($LowBound);
694 # set $LowBound to SQL statement:
695 # 'WHERE postings <=', 'HAVING MAX(postings) <=' or 'HAVING AVG(postings) <='
696 if ($Type eq 'level') {
697 $WhereHavingFunction = 'MAX(postings)'
698 } elsif ($Type eq 'average') {
699 $WhereHavingFunction = 'AVG(postings)'
700 } elsif ($Type eq 'sum') {
701 $WhereHavingFunction = 'SUM(postings)'
702 }
703 $UppBound = sprintf('%s <= '.$UppBound,$WhereHavingFunction) if ($UppBound);
704 return ($LowBound,$UppBound);
705};
706
707################################################################################
708sub SQLCheckNumber {
709################################################################################
710### check if input is a valid positive integer; otherwise, make it one
711### IN : @Numbers: array of parameters
712### OUT: @Numbers: a valid positive integer
713 my (@Numbers) = @_;
714 foreach my $Number (@Numbers) {
715 if ($Number and $Number < 0) {
716 &Bleat(1,"Boundary $Number is < 0, set to ".-$Number);
717 $Number = -$Number;
718 }
719 $Number = '' if ($Number and $Number !~ /^\d+$/);
720 }
721 return @Numbers;
722};
723
724################################################################################
725sub SQLBuildClause {
726################################################################################
727### build a valid SQL WHERE, GROUP BY, ORDER BY or HAVING clause
728### from multiple expressions which *may* be empty
729### IN : $Type: 'where', 'having', 'group' or 'order'
730### @Expressions: array of expressions
731### OUT: $SQLClause: a SQL clause
732 my ($Type,@Expressions) = @_;
733 my ($SQLClause,$Separator,$Statement);
734 # set separator ('AND' or ',')
735 if ($Type eq 'where' or $Type eq 'having') {
736 $Separator = 'AND';
737 } else {
738 $Separator = ',';
739 }
740 # set statement
741 if ($Type eq 'where') {
742 $Statement = 'WHERE';
743 } elsif ($Type eq 'order') {
744 $Statement = 'ORDER BY';
745 } elsif ($Type eq 'having') {
746 $Statement = 'HAVING';
747 } else {
748 $Statement = 'GROUP BY';
749 }
750 # build query from expressions with separators
751 foreach my $Expression (@Expressions) {
752 if ($Expression) {
753 $SQLClause .= " $Separator " if ($SQLClause);
754 $SQLClause .= $Expression;
755 }
756 }
757 # add statement in front if not already present
758 $SQLClause = " $Statement " . $SQLClause
759 if ($SQLClause and $SQLClause !~ /$Statement/);
760 return $SQLClause;
761};
762
c30822b4
TH		 763#####--------------------------- Verifications ----------------------------#####
764
765################################################################################
766sub CheckValidNewsgroups {
767################################################################################
768### syntax check of newgroup list
769### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*)
770### OUT: boolean
771 my ($Newsgroups) = @_;
772 my $InvalidCharRegExp = ',; ';
773 return ($Newsgroups =~ /[$InvalidCharRegExp]/) ? 0 : 1;
774};
775
edd250f2 776
741336c2
TH		 777#####------------------------------- done ---------------------------------#####
7781;
Usenet-Statistik
This page took 0.057422 seconds and 4 git commands to generate.