diff --git a/bin/cliservstats.pl b/bin/cliservstats.pl new file mode 100644 index 0000000..a38cba0 --- /dev/null +++ b/bin/cliservstats.pl @@ -0,0 +1,537 @@ +#! /usr/bin/perl +# +# cliservstats.pl +# +# This script will get statistical data on client (newsreader) and +# server (host) usage from a database. +# +# It is part of the NewsStats package. +# +# Copyright (c) 2025 Thomas Hochstein +# +# It can be redistributed and/or modified under the same terms under +# which Perl itself is published. + +BEGIN { + use File::Basename; + # we're in .../bin, so our module is in ../lib + push(@INC, dirname($0).'/../lib'); +} +use strict; +use warnings; + +use NewsStats qw(:DEFAULT :TimePeriods :Output :SQLHelper ReadGroupList); + +use DBI; +use Getopt::Long qw(GetOptions); +Getopt::Long::config ('bundling'); + +################################# Main program ################################# + +### read commandline options +my ($OptCaptions,$OptComments,$OptDB,$OptFileTemplate,$OptFormat, + $OptGroupBy,$LowBound,$OptMonth,$OptNames,$OptOrderBy, + $OptReportType,$OptSums,$OptType,$UppBound,$OptConfFile); +GetOptions ('c|captions!' => \$OptCaptions, + 'comments!' => \$OptComments, + 'db=s' => \$OptDB, + 'filetemplate=s' => \$OptFileTemplate, + 'f|format=s' => \$OptFormat, + 'g|group-by=s' => \$OptGroupBy, + 'l|lower=i' => \$LowBound, + 'm|month=s' => \$OptMonth, + 'n|names=s' => \$OptNames, + 'o|order-by=s' => \$OptOrderBy, + 'r|report=s' => \$OptReportType, + 's|sums!' => \$OptSums, + 't|type=s' => \$OptType, + 'u|upper=i' => \$UppBound, + 'conffile=s' => \$OptConfFile, + 'h|help' => \&ShowPOD, + 'V|version' => \&ShowVersion) or exit 1; +# parse parameters +# $OptComments defaults to TRUE if --filetemplate is not used +$OptComments = 1 if (!$OptFileTemplate && !defined($OptComments)); +# parse $OptType +if ($OptType) { + if ($OptType =~ /(host|server)s?/i) { + $OptType = 'host'; + } elsif ($OptType =~ /(newsreader|client)s?/i) { + $OptType = 'client'; + } +} +&Bleat(2, "Please use '--type server' or '-type newsreader'.") if !$OptType; +# parse $OptReportType +if ($OptReportType) { + if ($OptReportType =~ /sums?/i) { + $OptReportType = 'sum'; + } else { + $OptReportType = 'default'; + } +} + +### read configuration +my %Conf = %{ReadConfig($OptConfFile)}; + +### set DBTable +if ($OptDB) { + $Conf{'DBTable'} = $OptDB; +} +elsif ($OptType eq 'host') { + $Conf{'DBTable'} = $Conf{'DBTableHosts'}; +} else { + $Conf{'DBTable'} = $Conf{'DBTableClnts'}; +} + +### init database +my $DBHandle = InitDB(\%Conf,1); + +### get time period and names, prepare SQL 'WHERE' clause +# get time period +# and set caption for output and expression for SQL 'WHERE' clause +my ($CaptionPeriod,$SQLWherePeriod) = &GetTimePeriod($OptMonth); +# bail out if --month is invalid +&Bleat(2,"--month option has an invalid format - ". + "please use 'YYYY-MM', 'YYYY-MM:YYYY-MM' or 'ALL'!") if !$CaptionPeriod; +# get list of hosts and set expression for SQL 'WHERE' clause +# with placeholders as well as a list of names to bind to them +my ($SQLWhereNames,@SQLBindNames); +if ($OptNames) { + ($SQLWhereNames,@SQLBindNames) = &SQLGroupList($OptNames,$OptType); + # bail out if --names is invalid + &Bleat(2,"--names option has an invalid format!") + if !$SQLWhereNames; +} + +### build SQL WHERE clause +my $ExcludeSums = $OptSums ? '' : sprintf("%s != 'ALL'",$OptType); +my $SQLWhereClause = SQLBuildClause('where',$SQLWherePeriod,$SQLWhereNames, + $ExcludeSums, + &SQLSetBounds('default',$LowBound,$UppBound)); + +### get sort order and build SQL 'ORDER BY' clause +# force to 'month' for $OptReportType 'sum' +$OptGroupBy = 'month' if ($OptReportType and $OptReportType ne 'default'); +# default to 'name' if $OptGroupBy is not set and +# just one name is requested, but more than one month +$OptGroupBy = 'name' if (!$OptGroupBy and $OptMonth and $OptMonth =~ /:/ + and $OptNames and $OptNames !~ /[:*%]/); +# parse $OptGroupBy to $GroupBy, create ORDER BY clause $SQLOrderClause +# if $OptGroupBy is still not set, SQLSortOrder() will default to 'month' +my ($GroupBy,$SQLOrderClause) = SQLSortOrder($OptGroupBy, $OptOrderBy, $OptType); +# $GroupBy will contain 'month' or 'host'/'client' (parsed result of $OptGroupBy) +# set it to 'month' or 'key' for OutputData() +$GroupBy = ($GroupBy eq 'month') ? 'month' : 'key'; + +### get report type and build SQL 'SELECT' query +my $SQLSelect; +my $SQLGroupClause = ''; +my $Precision = 0; # number of digits right of decimal point for output +if ($OptReportType and $OptReportType ne 'default') { + $SQLGroupClause = "GROUP BY $OptType"; + # change $SQLOrderClause: replace everything before 'postings' + $SQLOrderClause =~ s/BY.+postings/BY postings/; + $SQLSelect = "'All months',$OptType,SUM(postings)"; + # change $SQLOrderClause: replace 'postings' with 'SUM(postings)' + $SQLOrderClause =~ s/postings/SUM(postings)/; + } else { + $SQLSelect = "month,$OptType,postings"; +}; + +### get length of longest name delivered by query +### for formatting purposes +my $Field = ($GroupBy eq 'month') ? $OptType : 'month'; +my ($MaxLength,$MaxValLength) = &GetMaxLength($DBHandle,$Conf{'DBTable'}, + $Field,'postings',$SQLWhereClause, + '',@SQLBindNames); + +### build and execute SQL query +my ($DBQuery); +# prepare query +$DBQuery = $DBHandle->prepare(sprintf('SELECT %s FROM %s.%s %s %s %s', + $SQLSelect, + $Conf{'DBDatabase'},$Conf{'DBTable'}, + $SQLWhereClause,$SQLGroupClause, + $SQLOrderClause)); +# execute query +$DBQuery->execute(@SQLBindNames) + or &Bleat(2,sprintf("Can't get %s data for %s from %s.%s: %s\n", + $OptType,$CaptionPeriod,$Conf{'DBDatabase'},$Conf{'DBTable'}, + $DBI::errstr)); + +### output results +# set default to 'pretty' +$OptFormat = 'pretty' if !$OptFormat; +# print captions if --caption is set +my $LeadIn; +if ($OptCaptions && $OptComments) { + # print time period with report type + my $CaptionReportType = '(number of postings for each month)'; + if ($OptReportType and $OptReportType ne 'default') { + $CaptionReportType = '(number of all postings for that time period)'; + } + $LeadIn .= sprintf("# ----- Report for %s %s\n",$CaptionPeriod,$CaptionReportType); + # print name list if --names is set + $LeadIn .= sprintf("# ----- Names: %s\n",join(',',split(/:/,$OptNames))) + if $OptNames; + # print boundaries, if set + my $CaptionBoundary= '(counting only month fulfilling this condition)'; + $LeadIn .= sprintf("# ----- Threshold: %s %s x %s %s %s\n", + $LowBound ? $LowBound : '',$LowBound ? '=>' : '', + $UppBound ? '<=' : '',$UppBound ? $UppBound : '',$CaptionBoundary) + if ($LowBound or $UppBound); + # print primary and secondary sort order + $LeadIn .= sprintf("# ----- Grouped by %s (%s), sorted %s%s\n", + ($GroupBy eq 'month') ? 'Months' : 'Names', + ($OptGroupBy and $OptGroupBy =~ /-?desc$/i) ? 'descending' : 'ascending', + ($OptOrderBy and $OptOrderBy =~ /posting/i) ? 'by number of postings ' : '', + ($OptOrderBy and $OptOrderBy =~ /-?desc$/i) ? 'descending' : 'ascending'); +} + +# output data +&OutputData($OptFormat,$OptComments,$GroupBy,$Precision,'',$LeadIn, + $OptFileTemplate,$DBQuery,$MaxLength,$MaxValLength); + +### close handles +$DBHandle->disconnect; + +__END__ + +################################ Documentation ################################# + +=head1 NAME + +cliservstats - create reports on host or client usage + +=head1 SYNOPSIS + +B B<-t> I [B<-Vhcs> B<--comments>] [B<-m> I[:I] | I] [B<-n> I] [B<-r> I] [B<-l> I] [B<-u> I] [B<-g> I] [B<-o> I] [B<-f> I] [B<--filetemplate> I] [B<--db> I] [B<--conffile> I] + +=head1 REQUIREMENTS + +See L. + +=head1 DESCRIPTION + +This script create reports on newsgroup usage (number of postings from +each host or using each client per month) taken from result tables +created by B. + +=head2 Features and options + +=head3 Time period and names + +The time period to act on defaults to last month; you can assign another +time period or a single month (or drop all time constraints) via the +B<--month> option (see below). + +B will process all hosts or clients by default; you can +limit processing to only some hosts or clients by supplying a list of +those names by using the B<--names> option (see below). + +=head3 Report type + +You can choose between different B<--report> types: postings per month +or all postings summed up; for details, see below. + +=head3 Upper and lower boundaries + +Furthermore you can set an upper and/or lower boundary to exclude some +results from output via the B<--lower> and B<--upper> options, +respectively. By default, all hosts/clients with more and/or less +postings per month will be excluded from the result set (i.e. not +shown and not considered forsum reports). + +=head3 Sorting and formatting the output + +By default, all results are grouped by month; you can group results by +hosts/clients instead via the B<--group-by> option. Within those +groups, the list of hosts/clients (or months) is sorted alphabetically +(or chronologically, respectively) ascending. You can change that order +(and sort by number of postings) with the B<--order-by> option. For +details and exceptions, please see below. + +The results will be formatted as a kind of table; you can change the +output format to a simple list or just a list of names and number of +postings with the B<--format> option. Captions will be added by means of +the B<--caption> option; all comments (and captions) can be supressed by +using B<--nocomments>. + +Last but not least you can redirect all output to a number of files, e.g. +one for each month, by submitting the B<--filetemplate> option, see below. + +=head2 Configuration + +B will read its configuration from F +which should be present in etc/ via Config::Auto or from a configuration file +submitted by the B<--conffile> option. + +See doc/INSTALL for an overview of possible configuration options. + +You can override some configuration options via the B<--db> option. + +=head1 OPTIONS + +=over 3 + +=item B<-V>, B<--version> + +Print out version and copyright information and exit. + +=item B<-h>, B<--help> + +Print this man page and exit. + +=item B<-t>, B<--type> I + +Create report for hosts (servers) or clients (newsreaders), using +I or I respectively. + +=item B<-m>, B<--month> I + +Set processing period to a single month in YYYY-MM format or to a time +period between two month in YYYY-MM:YYYY-MM format (two month, separated +by a colon). By using the keyword I instead, you can set no +processing period to process the whole database. + +=item B<-n>, B<--names> I + +Limit processing to a certain set of host or client names. I +can be a single name (eternal-september.org), a group of names +(*.inka.de) or a list of either of these, separated by colons, for +example + + eternal-september.org:solani.org:*.inka.de + +=item B<-s>, B<--sums|--nosums> (sum per month) + +Include a "virtual" host named "ALL" for every month in output, +containing the sum of all detected hosts for that month. + +=item B<-r>, B<--report> I + +Choose the report type: I or I + +By default, B will report the number of postings for each +host/client in each month. But it can also report the total sum of postings +per host/client for all months. + +For report type I, the B option has no meaning and +will be silently ignored (see below). + +=item B<-l>, B<--lower> I + +Set the lower boundary. See below. + +=item B<-l>, B<--upper> I + +Set the upper boundary. + +By default, all hosts/clients with more postings per month than the +upper boundary and/or less postings per month than the lower boundary +will be excluded from further processing. For the default report that +means each month only hosts/clients with a number of postings between +the boundaries will be displayed. For the sums report, hosts/clients +with a number of postings exceeding the boundaries in all (!) months +will not be considered. + +=item B<-g>, B<--group-by> I + +By default, all results are grouped by month, sorted chronologically in +ascending order, like this: + + # ----- 2012-01: + arcor-online.net : 9379 + individual.net : 19525 + news.albasani.net: 9063 + # ----- 2012-02: + arcor-online.net : 8606 + individual.net : 16768 + news.albasani.net: 7879 + +The results can be grouped by host/client instead via +B<--group-by> I: + + ----- individual.net + 2012-01: 19525 + 2012-02: 16768 + ----- arcor-online.net + 2012-01: 9379 + 2012-02: 8606 + ----- news.albasani.net + 2012-01: 9063 + 2012-02: 7879 + +By appending I<-desc> to the group-by option parameter, you can reverse +the sort order - e.g. B<--group-by> I will give: + + # ----- 2012-02: + arcor-online.net : 8606 + individual.net : 16768 + news.albasani.net: 7879 + # ----- 2012-01: + arcor-online.net : 9379 + individual.net : 19525 + news.albasani.net: 9063 + +Sums reports (see above) will always be grouped by months; this option +will therefore be ignored. + +=item B<-o>, B<--order-by> I + +Within each group (a single month or single host/client, see above), +the report will be sorted by name (or month) in ascending alphabetical +order by default. You can change the sort order to descending or sort +by number of postings instead. + +=item B<-f>, B<--format> I + +Select the output format, I being the default: + + # ----- 2012-01: + arcor-online.net : 9379 + individual.net : 19525 + # ----- 2012-02: + arcor-online.net : 8606 + individual.net : 16768 + +I format looks like this: + + 2012-01 arcor-online.net 9379 + 2012-01 individual.net 19525 + 2012-02 arcor-online.net 8606 + 2012-02 individual.net 16768 + +And I format looks like this: + + # 2012-01: + arcor-online.net 9379 + individual.net 19525 + # 2012-02: + arcor-online.net 8606 + individual.net 16768 + +You can remove the comments by using B<--nocomments>, see below. + +=item B<-c>, B<--captions|--nocaptions> + +Add captions to output, like this: + + ----- Report for 2012-01 to 2012-02 (number of postings for each month) + ----- Names: individual.net + ----- Threshold: 8000 => x (counting only month fulfilling this condition) + ----- Grouped by Month (ascending), sorted by number of postings descending + +False by default. + +=item B<--comments|--nocomments> + +Add comments (group headers) to I and I output. True by default +as logn as B<--filetemplate> is not set. + +Use I<--nocomments> to suppress anything except host/client names or months and +numbers of postings. + +=item B<--filetemplate> I + +Save output to file(s) instead of dumping it to STDOUT. B will +create one file for each month (or each host/client, accordant to the +setting of B<--group-by>, see above), with filenames composed by adding +year and month (or host/client names) to the I, for +example with B<--filetemplate> I: + + stats-2012-01 + stats-2012-02 + ... and so on + +=item B<--db> I + +Override I or I from F. + +=item B<--conffile> I + +Load configuration from I instead of F. + +=back + +=head1 INSTALLATION + +See L. + +=head1 EXAMPLES + +Show number of postings per group for lasth month in I format: + + cliservstats --type host + +Show that report for January of 2010 and *.inka plus individual.net: + + cliservstats --type host --month 2010-01 --names *.inka:individual.net: + +Only show clients with 30 postings or less last month, ordered +by number of postings, descending, in I format: + + cliservstats --type client --upper 30 --order-by postings-desc + +List number of postings per host for each month of 2010 and redirect +output to one file for each month, named hosts-2010-01 and so on, in +machine-readable form (without formatting): + + cliservstats -t host -m 2010-01:2010-12 -f dump --filetemplate hosts + + +=head1 FILES + +=over 4 + +=item F + +The script itself. + +=item F + +Library functions for the NewsStats package. + +=item F + +Runtime configuration file. + +=back + +=head1 BUGS + +Please report any bugs or feature requests to the author or use the +bug tracker at L! + +=head1 SEE ALSO + +=over 2 + +=item - + +L + +=item - + +l>doc/INSTALL> + +=item - + +gatherstats -h + +=back + +This script is part of the B package. + +=head1 AUTHOR + +Thomas Hochstein + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2025 Thomas Hochstein + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/install/install.pl b/bin/dbcreate.pl similarity index 84% rename from install/install.pl rename to bin/dbcreate.pl index 826052d..ea0fd6c 100755 --- a/install/install.pl +++ b/bin/dbcreate.pl @@ -1,19 +1,19 @@ #! /usr/bin/perl # -# install.pl +# dbcreate.pl # # This script will create database tables as necessary. # # It is part of the NewsStats package. # -# Copyright (c) 2010-2013 Thomas Hochstein +# Copyright (c) 2010-2013, 2025 Thomas Hochstein # # It can be redistributed and/or modified under the same terms under # which Perl itself is published. BEGIN { use File::Basename; - # we're in .../install, so our module is in ../lib + # we're in .../bin, so our module is in ../lib push(@INC, dirname($0).'/../lib'); } use strict; @@ -46,7 +46,7 @@ my $DBCreate = < < < < < <connect(sprintf('DBI:%s:host=%s',$Conf{'DBDriver'}, $Conf{'DBHost'}), $Conf{'DBUser'}, $Conf{'DBPw'}, { PrintError => 0 }); @@ -162,7 +178,7 @@ if (!$OptUpdate) { $DBQuery->execute() or &Bleat(2, sprintf("Can't create database %s: %s%\n", $Conf{'DBDatabase'}, $DBI::errstr)); - printf("Database table %s created succesfully.\n",$Conf{'DBDatabase'}); + printf("Database %s created succesfully.\n",$Conf{'DBDatabase'}); $DBHandle->disconnect; }; @@ -185,7 +201,7 @@ if (!$OptUpdate) { } else { ##### upgrade mode print "----------\nStarting upgrade process.\n"; - $PackageVersion = '0.03'; + my $PackageVersion = '0.03'; if ($OptUpdate < $PackageVersion) { if ($OptUpdate < 0.02) { # 0.01 -> 0.02 @@ -215,7 +231,7 @@ sub CreateTable { }; my $DBQuery = $DBHandle->prepare($DBCreate{$Table}); $DBQuery->execute() or - &Bleat(2, sprintf("Can't create table %s in database %s: %s%\n",$Table, + &Bleat(2, sprintf("Can't create table %s in database %s: %s\n",$Table, $Conf{'DBDatabase'},$DBI::errstr)); printf("Database table %s.%s created succesfully.\n", $Conf{'DBDatabase'},$Conf{$Table}); @@ -245,11 +261,11 @@ __END__ =head1 NAME -install - installation script +dbcreate - database creation script =head1 SYNOPSIS -B [B<-Vh> [--update I] [B<--conffile> I] +B [B<-Vh> [--update I] [B<--conffile> I] =head1 REQUIREMENTS @@ -257,11 +273,12 @@ See L. =head1 DESCRIPTION -This script will create database tables as necessary and configured. +This script will create a database and database tables as necessary +and configured. =head2 Configuration -B will read its configuration from F which should +B will read its configuration from F which should be present in etc/ via Config::Auto or from a configuration file submitted by the B<--conffile> option. @@ -293,7 +310,7 @@ Load configuration from I instead of F. =over 4 -=item F +=item F The script itself. @@ -334,7 +351,7 @@ Thomas Hochstein =head1 COPYRIGHT AND LICENSE -Copyright (c) 2010-2013 Thomas Hochstein +Copyright (c) 2010-2013, 2025 Thomas Hochstein This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/bin/gatherstats.pl b/bin/gatherstats.pl index 60043d1..15b7ad4 100755 --- a/bin/gatherstats.pl +++ b/bin/gatherstats.pl @@ -7,7 +7,7 @@ # # It is part of the NewsStats package. # -# Copyright (c) 2010-2013 Thomas Hochstein +# Copyright (c) 2010-2013, 2025 Thomas Hochstein # # It can be redistributed and/or modified under the same terms under # which Perl itself is published. @@ -20,7 +20,7 @@ BEGIN { use strict; use warnings; -use NewsStats qw(:DEFAULT :TimePeriods ListNewsgroups ParseHierarchies ReadGroupList); +use NewsStats qw(:DEFAULT :TimePeriods ListNewsgroups ParseHierarchies ReadGroupList ParseHeaders); use DBI; use Getopt::Long qw(GetOptions); @@ -31,19 +31,21 @@ Getopt::Long::config ('bundling'); # define types of information that can be gathered # all / groups (/ clients / hosts) my %LegalStats; -@LegalStats{('all','groups')} = (); +@LegalStats{('all','groups','hosts')} = (); ################################# Main program ################################# ### read commandline options my ($OptCheckgroupsFile,$OptClientsDB,$OptDebug,$OptGroupsDB,$OptTLH, - $OptHostsDB,$OptMonth,$OptRawDB,$OptStatsType,$OptTest,$OptConfFile); + $OptHostsDB,$OptMID,$OptMonth,$OptRawDB,$OptStatsType,$OptTest, + $OptConfFile); GetOptions ('c|checkgroups=s' => \$OptCheckgroupsFile, 'clientsdb=s' => \$OptClientsDB, - 'd|debug!' => \$OptDebug, + 'd|debug+' => \$OptDebug, 'groupsdb=s' => \$OptGroupsDB, 'hierarchy=s' => \$OptTLH, 'hostsdb=s' => \$OptHostsDB, + 'mid=s' => \$OptMID, 'm|month=s' => \$OptMonth, 'rawdb=s' => \$OptRawDB, 's|stats=s' => \$OptStatsType, @@ -64,6 +66,11 @@ $ConfOverride{'DBTableHosts'} = $OptHostsDB if $OptHostsDB; $ConfOverride{'TLH'} = $OptTLH if $OptTLH; &OverrideConfig(\%Conf,\%ConfOverride); +# set --debug and --test if --mid is set +if ($OptMID) { + $OptDebug = 1; $OptTest = 1; +} + ### get type of information to gather, defaulting to 'all' $OptStatsType = 'all' if !$OptStatsType; &Bleat(2, sprintf("Unknown type '%s'!", $OptStatsType)) @@ -108,6 +115,9 @@ if ($Conf{'TLH'}) { ### init database my $DBHandle = InitDB(\%Conf,1); +my $DBRaw = sprintf('%s.%s',$Conf{'DBDatabase'},$Conf{'DBTableRaw'}); +my $DBGrps = sprintf('%s.%s',$Conf{'DBDatabase'},$Conf{'DBTableGrps'}); +my $DBHosts = sprintf('%s.%s',$Conf{'DBDatabase'},$Conf{'DBTableHosts'}); ### get data for each month &Bleat(1,'Test mode. Database is not updated.') if $OptTest; @@ -115,90 +125,262 @@ foreach my $Month (&ListMonth($Period)) { print "---------- $Month ----------\n" if $OptDebug; + ### GroupStats if ($OptStatsType eq 'all' or $OptStatsType eq 'groups') { - # read list of newsgroups from --checkgroups - # into a hash - my %ValidGroups = %{ReadGroupList(sprintf('%s-%s',$OptCheckgroupsFile,$Month))} - if $OptCheckgroupsFile; + &GroupStats($DBHandle,$DBRaw,$DBGrps,$Month,$TLH,$OptCheckgroupsFile,$OptMID,$OptTest,$OptDebug); + }; - ### ---------------------------------------------- - ### get groups data (number of postings per group) - # get groups data from raw table for given month - my $DBQuery = $DBHandle->prepare(sprintf("SELECT newsgroups FROM %s.%s ". - "WHERE day LIKE ? AND NOT disregard", - $Conf{'DBDatabase'}, - $Conf{'DBTableRaw'})); - $DBQuery->execute($Month.'-%') - or &Bleat(2,sprintf("Can't get groups data for %s from %s.%s: ". - "$DBI::errstr\n",$Month, - $Conf{'DBDatabase'},$Conf{'DBTableRaw'})); - - # count postings per group - my %Postings; - while (($_) = $DBQuery->fetchrow_array) { - # get list of newsgroups and hierarchies from Newsgroups: - my %Newsgroups = ListNewsgroups($_,$TLH, - $OptCheckgroupsFile ? \%ValidGroups : ''); - # count each newsgroup and hierarchy once - foreach (sort keys %Newsgroups) { - $Postings{$_}++; - }; - }; - - # add valid but empty groups if --checkgroups is set - if (%ValidGroups) { - foreach (sort keys %ValidGroups) { - if (!defined($Postings{$_})) { - # add current newsgroup as empty group - $Postings{$_} = 0; - warn (sprintf("ADDED: %s as empty group\n",$_)); - # add empty hierarchies for current newsgroup as needed - foreach (ParseHierarchies($_)) { - my $Hierarchy = $_ . '.ALL'; - if (!defined($Postings{$Hierarchy})) { - $Postings{$Hierarchy} = 0; - warn (sprintf("ADDED: %s as empty group\n",$Hierarchy)); - }; - }; - } - }; - }; - - # delete old data for that month - if (!$OptTest) { - $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s.%s WHERE month = ?", - $Conf{'DBDatabase'},$Conf{'DBTableGrps'}), - undef,$Month) - or &Bleat(2,sprintf("Can't delete old groups data for %s from %s.%s: ". - "$DBI::errstr\n",$Month, - $Conf{'DBDatabase'},$Conf{'DBTableGrps'})); - }; - - print "----- GroupStats -----\n" if $OptDebug; - foreach my $Newsgroup (sort keys %Postings) { - print "$Newsgroup => $Postings{$Newsgroup}\n" if $OptDebug; - if (!$OptTest) { - # write to database - $DBQuery = $DBHandle->prepare(sprintf("INSERT INTO %s.%s ". - "(month,newsgroup,postings) ". - "VALUES (?, ?, ?)", - $Conf{'DBDatabase'}, - $Conf{'DBTableGrps'})); - $DBQuery->execute($Month, $Newsgroup, $Postings{$Newsgroup}) - or &Bleat(2,sprintf("Can't write groups data for %s/%s to %s.%s: ". - "$DBI::errstr\n",$Month,$Newsgroup, - $Conf{'DBDatabase'},$Conf{'DBTableGrps'})); - $DBQuery->finish; - }; - }; - } else { - # other types of information go here - later on + ### HostStats + if ($OptStatsType eq 'all' or $OptStatsType eq 'hosts') { + # define known hosts using subdomains + my @KnownHosts = qw(abavia.com aioe.org arcor-online.net arcor-ip.de astraweb.com read.cnntp.org + easynews.com eternal-september.org euro.net fernuni-hagen.de free.fr newsread.freenet.ag + googlegroups.com heirich.name news.neostrada.pl netcologne.de newsdawg.com newscene.com + news-service.com octanews.com readnews.com wieslauf.sub.de highway.telekom.at + united-newsserver.de xennanews.com xlned.com xsnews.nl news.xs4all.nl); + &HostStats($DBHandle,$DBRaw,$DBHosts,$Month,$OptMID,$OptTest,$OptDebug,@KnownHosts); }; }; ### close handles $DBHandle->disconnect; +################################# Subroutines ################################## + +sub GroupStats { +### ---------------------------------------------------------------------------- +### collect number of postings per group +### IN : $DBHandle : database handle +### $DBRaw : database table for raw data (to read from) +### $DBGrps : database table for groups data (to write to) +### $Month : current month to do +### $MID : specific Message-ID to fetch (testing purposes) +### $TLH : TLHs to collect +### $Checkgroupsfile : filename template for checkgroups file +### (expanded to $Checkgroupsfile-$Month) +### $Test : test mode +### $Debug : debug mode +### OUT: (nothing) + my ($DBHandle,$DBRaw,$DBGrps,$Month,$TLH,$CheckgroupsFile,$MID,$Test,$Debug) = @_; + + # read list of newsgroups from --checkgroups + # into a hash + my %ValidGroups = %{ReadGroupList(sprintf('%s-%s',$CheckgroupsFile,$Month))} + if $CheckgroupsFile; + + my $DBQuery; + if (!$MID) { + ### ---------------------------------------------- + ### get groups data (number of postings per group) + # get groups data from raw table for given month + $DBQuery = $DBHandle->prepare(sprintf("SELECT newsgroups FROM %s ". + "WHERE day LIKE ? AND NOT disregard", + $DBRaw)); + $DBQuery->execute($Month.'-%') + or &Bleat(2,sprintf("Can't get groups data for %s from %s: ". + "$DBI::errstr\n",$Month, + $DBRaw)); + } else { + $DBQuery = $DBHandle->prepare(sprintf("SELECT newsgroups FROM %s ". + "WHERE mid = ?", $DBRaw)); + $DBQuery->execute($MID) + or &Bleat(2,sprintf("Can't get groups data for %s from %s: ". + "$DBI::errstr\n",$MID, + $DBRaw)); + } + + # count postings per group + my %Postings; + while (($_) = $DBQuery->fetchrow_array) { + # get list of newsgroups and hierarchies from Newsgroups: + my %Newsgroups = ListNewsgroups($_,$TLH, + $CheckgroupsFile ? \%ValidGroups : ''); + # count each newsgroup and hierarchy once + foreach (sort keys %Newsgroups) { + $Postings{$_}++; + }; + }; + + # add valid but empty groups if --checkgroups is set + if (%ValidGroups) { + foreach (sort keys %ValidGroups) { + if (!defined($Postings{$_})) { + # add current newsgroup as empty group + $Postings{$_} = 0; + warn (sprintf("ADDED: %s as empty group\n",$_)); + # add empty hierarchies for current newsgroup as needed + foreach (ParseHierarchies($_)) { + my $Hierarchy = $_ . '.ALL'; + if (!defined($Postings{$Hierarchy})) { + $Postings{$Hierarchy} = 0; + warn (sprintf("ADDED: %s as empty group\n",$Hierarchy)); + }; + }; + } + }; + }; + + # delete old data for that month + if (!$Test) { + $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s WHERE month = ?", + $DBGrps), undef,$Month) + or &Bleat(2,sprintf("Can't delete old groups data for %s from %s: ". + "$DBI::errstr\n",$Month,$DBGrps)); + }; + + print "----- GroupStats -----\n" if $Debug; + foreach my $Newsgroup (sort keys %Postings) { + print "$Newsgroup => $Postings{$Newsgroup}\n" if $Debug; + if (!$Test) { + # write to database + $DBQuery = $DBHandle->prepare(sprintf("INSERT INTO %s ". + "(month,newsgroup,postings) ". + "VALUES (?, ?, ?)",$DBGrps)); + $DBQuery->execute($Month, $Newsgroup, $Postings{$Newsgroup}) + or &Bleat(2,sprintf("Can't write groups data for %s/%s to %s: ". + "$DBI::errstr\n",$Month,$Newsgroup,$DBGrps)); + $DBQuery->finish; + }; + }; +}; +### ---------------------------------------------------------------------------- + +sub HostStats { +### ---------------------------------------------------------------------------- +### collect number of postings per server +### IN : $DBHandle : database handle +### $DBRaw : database table for raw data (to read from) +### $DBHosts : database table for hosts data (to write to) +### $Month : current month to do +### $MID : specific Message-ID to fetch (testing purposes) +### $Test : test mode +### $Debug : debug mode +### @KnownHosts : list of known hosts with subdomains +### OUT: (nothing) + my ($DBHandle,$DBRaw,$DBHosts,$Month,$MID,$Test,$Debug,@KnownHosts) = @_; + + my (%Postings,$DBQuery); + + if (!$MID) { + # get raw header data from raw table for given month + $DBQuery = $DBHandle->prepare(sprintf("SELECT newsgroups,headers FROM %s ". + "WHERE day LIKE ? AND NOT disregard", + $DBRaw)); + $DBQuery->execute($Month.'-%') + or &Bleat(2,sprintf("Can't get hosts data for %s from %s: ". + "$DBI::errstr\n",$Month,$DBRaw)); + } else { + $DBQuery = $DBHandle->prepare(sprintf("SELECT newsgroups,headers FROM %s ". + "WHERE mid = ?", $DBRaw)); + $DBQuery->execute($MID) + or &Bleat(2,sprintf("Can't get hosts data for %s from %s: ". + "$DBI::errstr\n",$MID,$DBRaw)); + } + + ### ---------------------------------------------- + print "----- HostStats -----\n" if $Debug; + ### parse headers + while (my ($Newsgroups,$Headers) = $DBQuery->fetchrow_array) { + ### skip postings with wrong TLH + # remove whitespace from contents of Newsgroups: + chomp($Newsgroups); + $Newsgroups =~ s/\s//; + my $GroupCount; + for (split /,/, $Newsgroups) { + # don't count newsgroup/hierarchy in wrong TLH + next if($TLH and !/^$TLH/); + $GroupCount++; + }; + next if !$GroupCount; + + my $Host; + my %Header = ParseHeaders(split(/\n/,$Headers)); + + # ([a-z0-9-_]+\.[a-z0-9-_.]+) tries to match a hostname + # Injection-Info + if($Header{'injection-info'}) { + ($Host) = $Header{'injection-info'} =~ /^\s*([a-z0-9-_]+\.[a-z0-9-_.]+);/i; + # reset if IP address + undef($Host) if $Host && $Host !~ /[g-z]/i; + } + # X-Trace + if (!$Host && $Header{'x-trace'}) { + (undef, $Host) = $Header{'x-trace'} =~ /^(\s|\d)*([a-z0-9-_]+\.[a-z0-9-_.]+)/i; + # reset if IP address + undef($Host) if $Host && $Host !~ /[g-z]/i; + } + # Path + if (!$Host) { + if ($Header{'path'} =~ /!([^!]+)!.POSTED!/) { + $Host = "$1"; + } elsif ($Header{'path'} =~ /([^!]+)!.POSTED.[^!]+!?/) { + $Host = "$1"; + } else { + # iterate on the Path: header until we have a host name or no more + # path elements + while (!$Host && $Header{'path'} =~ /!/) { + ($Host) = $Header{'path'} =~ /!?([a-z0-9-_]+\.[a-z0-9-_.]+)!!?[^!]+!?$/i; + undef($Host) if $Host && $Host =~ /\.MISMATCH/; + # remove last path element + $Header{'path'} =~ s/!!?[^!]+$//; + }; + } + } + + # trailing .POSTED + ($Host) = $Host =~ /(\S+)\.POSTED$/ if $Host =~ /\.POSTED$/; + + # special cases + $Host = 'news.highwinds-media.com' if $Host =~ /f(e|x)\d\d\.\S{3}\d?$/ + or $Host =~ /(newsfe|fed)\d+\.(iad|ams2)$/; + $Host = 'newshosting.com' if $Host =~ /post\d*\.iad$/; + $Host = 'eternal-september.org' if $Host =~ /dont-email\.me$/; + + # normalize hosts + foreach (@KnownHosts) { + if ($Host =~ /\.$_$/) { + ($Host) = $_ ; + last; + } + } + + # lowercase + $Host = lc($Host); + + # count host + if ($Host) { + $Postings{$Host}++; + $Postings{'ALL'}++; + } else { + &Bleat(2,sprintf("%s FAILED", $Header{'message-id'})) if !$Host; + } + + printf("%s: %s\n", $Header{'message-id'}, $Host) if ($MID or $Debug && $Debug >1); + }; + + # delete old data for that month + if (!$Test) { + $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s WHERE month = ?", + $DBHosts),undef,$Month) + or &Bleat(2,sprintf("Can't delete old hosts data for %s from %s: ". + "$DBI::errstr\n",$Month,$DBHosts)); + }; + + foreach my $Host (sort keys %Postings) { + print "$Host => $Postings{$Host}\n" if $Debug; + if (!$Test) { + # write to database + $DBQuery = $DBHandle->prepare(sprintf("INSERT INTO %s ". + "(month,host,postings) ". + "VALUES (?, ?, ?)",$DBHosts)); + $DBQuery->execute($Month, $Host, $Postings{$Host}) + or &Bleat(2,sprintf("Can't write groups data for %s/%s to %s: ". + "$DBI::errstr\n",$Month,$Host,$DBHosts)); + $DBQuery->finish; + }; + }; +}; + __END__ ################################ Documentation ################################# @@ -231,9 +413,7 @@ below). By default B will process all types of information; you can change that using the B<--stats> option and assigning the type of -information to process. Currently that doesn't matter yet as only -processing of the number of postings per group per month is -implemented anyway. +information to process. Possible information types include: @@ -255,6 +435,15 @@ only once for de.alt.ALL and de.ALL. Data is written to I (see L); you can override that default through the B<--groupsdb> option. +=item B (postings from host per month) + +B will examine Injection-Info:, X-Trace: and Path: +headers and try to normalize them. Groups not in I will be +ignored. The sum of all detected hosts will also saved for each month. + +Data is written to I (see L); you can +override that default through the B<--hostsdb> option. + =back =head2 Configuration @@ -299,9 +488,8 @@ by a colon). =item B<-s>, B<--stats> I -Set processing type to one of I and I. Defaults to all -(and is currently rather pointless as only I has been -implemented). +Set processing type to one of I, I or I. Defaults +to all. =item B<-c>, B<--checkgroups> I @@ -417,7 +605,7 @@ Thomas Hochstein =head1 COPYRIGHT AND LICENSE -Copyright (c) 2010-2013 Thomas Hochstein +Copyright (c) 2010-2013, 2025 Thomas Hochstein This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/bin/groupstats.pl b/bin/groupstats.pl index b716566..cc13550 100755 --- a/bin/groupstats.pl +++ b/bin/groupstats.pl @@ -51,10 +51,8 @@ GetOptions ('b|boundary=s' => \$OptBoundType, 'h|help' => \&ShowPOD, 'V|version' => \&ShowVersion) or exit 1; # parse parameters -# $OptComments defaults to TRUE -$OptComments = 1 if (!defined($OptComments)); -# force --nocomments when --filetemplate is used -$OptComments = 0 if ($OptFileTemplate); +# $OptComments defaults to TRUE if --filetemplate is not used +$OptComments = 1 if (!$OptFileTemplate && !defined($OptComments)); # parse $OptBoundType if ($OptBoundType) { if ($OptBoundType =~ /level/i) { @@ -110,7 +108,7 @@ my ($CaptionPeriod,$SQLWherePeriod) = &GetTimePeriod($OptMonth); # with placeholders as well as a list of newsgroup to bind to them my ($SQLWhereNewsgroups,@SQLBindNewsgroups); if ($OptNewsgroups) { - ($SQLWhereNewsgroups,@SQLBindNewsgroups) = &SQLGroupList($OptNewsgroups); + ($SQLWhereNewsgroups,@SQLBindNewsgroups) = &SQLGroupList($OptNewsgroups,'newsgroup'); # bail out if --newsgroups is invalid &Bleat(2,"--newsgroups option has an invalid format!") if !$SQLWhereNewsgroups; @@ -143,7 +141,7 @@ $OptGroupBy = 'newsgroup' if (!$OptGroupBy and $OptMonth and $OptMonth =~ /:/ and $OptNewsgroups and $OptNewsgroups !~ /[:*%]/); # parse $OptGroupBy to $GroupBy, create ORDER BY clause $SQLOrderClause # if $OptGroupBy is still not set, SQLSortOrder() will default to 'month' -my ($GroupBy,$SQLOrderClause) = SQLSortOrder($OptGroupBy, $OptOrderBy); +my ($GroupBy,$SQLOrderClause) = SQLSortOrder($OptGroupBy, $OptOrderBy, 'newsgroup'); # $GroupBy will contain 'month' or 'newsgroup' (parsed result of $OptGroupBy) # set it to 'month' or 'key' for OutputData() $GroupBy = ($GroupBy eq 'month') ? 'month' : 'key'; @@ -226,6 +224,7 @@ $DBQuery->execute(@SQLBindNewsgroups) # set default to 'pretty' $OptFormat = 'pretty' if !$OptFormat; # print captions if --caption is set +my $LeadIn; if ($OptCaptions && $OptComments) { # print time period with report type my $CaptionReportType= '(number of postings for each month)'; @@ -235,9 +234,9 @@ if ($OptCaptions && $OptComments) { $CaptionReportType= '(number of all postings for that time period)' if $OptReportType eq 'sum'; } - printf("# ----- Report for %s %s\n",$CaptionPeriod,$CaptionReportType); + $LeadIn .= sprintf("# ----- Report for %s %s\n",$CaptionPeriod,$CaptionReportType); # print newsgroup list if --newsgroups is set - printf("# ----- Newsgroups: %s\n",join(',',split(/:/,$OptNewsgroups))) + $LeadIn .= sprintf("# ----- Newsgroups: %s\n",join(',',split(/:/,$OptNewsgroups))) if $OptNewsgroups; # print boundaries, if set my $CaptionBoundary= '(counting only month fulfilling this condition)'; @@ -246,12 +245,12 @@ if ($OptCaptions && $OptComments) { $CaptionBoundary= '(on average)' if $OptBoundType eq 'average'; $CaptionBoundary= '(all month summed up)' if $OptBoundType eq 'sum'; } - printf("# ----- Threshold: %s %s x %s %s %s\n", + $LeadIn .= sprintf("# ----- Threshold: %s %s x %s %s %s\n", $LowBound ? $LowBound : '',$LowBound ? '=>' : '', $UppBound ? '<=' : '',$UppBound ? $UppBound : '',$CaptionBoundary) if ($LowBound or $UppBound); # print primary and secondary sort order - printf("# ----- Grouped by %s (%s), sorted %s%s\n", + $LeadIn .= sprintf("# ----- Grouped by %s (%s), sorted %s%s\n", ($GroupBy eq 'month') ? 'Months' : 'Newsgroups', ($OptGroupBy and $OptGroupBy =~ /-?desc$/i) ? 'descending' : 'ascending', ($OptOrderBy and $OptOrderBy =~ /posting/i) ? 'by number of postings ' : '', @@ -260,7 +259,7 @@ if ($OptCaptions && $OptComments) { # output data &OutputData($OptFormat,$OptComments,$GroupBy,$Precision, - $OptCheckgroupsFile ? $ValidGroups : '', + $OptCheckgroupsFile ? $ValidGroups : '',$LeadIn, $OptFileTemplate,$DBQuery,$MaxLength,$MaxValLength); ### close handles @@ -336,7 +335,6 @@ using B<--nocomments>. Last but not least you can redirect all output to a number of files, e.g. one for each month, by submitting the B<--filetemplate> option, see below. -Captions and comments are automatically disabled in this case. =head2 Configuration @@ -589,10 +587,11 @@ False by default. =item B<--comments|--nocomments> -Add comments (group headers) to I and I output. True by default. +Add comments (group headers) to I and I output. True by default +as logn as B<--filetemplate> is not set. Use I<--nocomments> to suppress anything except newsgroup names/months and -numbers of postings. This is enforced when using B<--filetemplate>, see below. +numbers of postings. =item B<--filetemplate> I @@ -606,8 +605,6 @@ example with B<--filetemplate> I: stats-2012-02 ... and so on -B<--nocomments> is enforced, see above. - =item B<--groupsdb> I Override I from F. diff --git a/bin/postingstats.pl b/bin/postingstats.pl new file mode 100644 index 0000000..e6fe3db --- /dev/null +++ b/bin/postingstats.pl @@ -0,0 +1,354 @@ +#!/usr/bin/perl +# +# postingstats.pl +# +# This script will create statistic postings from NewsStats output. +# It defaults to statistics for de.* posted to de.admin.lists, but +# defaults can be changed at ----- configuration -----. +# +# It is part of the NewsStats package. +# +# Copyright (c) 2010-2012, 2025 Thomas Hochstein +# +# It can be redistributed and/or modified under the same terms under +# which Perl itself is published. +# +# Usage: +# $~ groupstats.pl --nocomments --sums --format dump | postingstats.pl -t groups +# $~ cliservstats.pl -t server --nocomments --sums --format dump | postingstats.pl -t hosts +# + +BEGIN { + use File::Basename; + # we're in .../bin, so our module is in ../lib + push(@INC, dirname($0).'/../lib'); +} +use strict; +use warnings; + +use NewsStats qw(:DEFAULT LastMonth); + +use Getopt::Long qw(GetOptions); +Getopt::Long::config ('bundling'); + +use constant TABLEWIDTH => 28; # width of table without newsgroup name + +##### ----- pre-config ----------------------------------------------- +### read commandline options +my ($Month, $Type); +GetOptions ('m|month=s' => \$Month, + 't|type=s' => \$Type, + 'h|help' => \&ShowPOD, + 'V|version' => \&ShowVersion) or exit 1; +$Month = &LastMonth if !$Month; +if ($Month !~ /^\d{4}-\d{2}$/) { + $Month = &LastMonth; + &Bleat(1,"--month option has an invalid format - set to $Month."); +}; +# parse $Type +if (!$Type) { + # default + $Type = 'GroupStats'; +} elsif ($Type =~ /(news)?groups?/i) { + $Type = 'GroupStats'; +} elsif ($Type =~ /(host|server)s?/i) { + $Type = 'HostStats'; +}; +my $Timestamp = time; + +##### ----- configuration -------------------------------------------- +my $TLH = 'de'; +my %Heading = ('GroupStats' => 'Postingstatistik fuer de.* im Monat '.$Month, + 'HostStats' => 'Serverstatistik fuer de.* im Monat '.$Month + ); +my %TH = ('counter' => 'Nr.', + 'value' => 'Anzahl', + 'percentage' => 'Prozent' + ); +my %LeadIn = ('GroupStats' => < < +Newsgroups: local.test +Subject: Postingstatistik fuer de.* im Monat $Month +Message-ID: +Approved: thh\@thh.name +Mime-Version: 1.0 +Content-Type: text/plain; charset=us-ascii +Content-Transfer-Encoding: 7bit +User-Agent: postingstats.pl/$VERSION (NewsStats) + +GROUPSIN +From: Thomas Hochstein +Newsgroups: local.test +Subject: Serverstatistik fuer de.* im Monat $Month +Message-ID: +Approved: thh\@thh.name +Mime-Version: 1.0 +Content-Type: text/plain; charset=us-ascii +Content-Transfer-Encoding: 7bit +User-Agent: postingstats.pl/$VERSION (NewsStats) + +HOSTSIN +my %LeadOut = ('GroupStats' => < < zur +Verfuegung. +GROUPSOUT + +Alle Zahlen wurden ermittelt auf einem Newsserver mit redundanter Anbin- +dung fuer de.* unter Anwendung ueblicher Filtermassnahmen. Steuernach- +richten werden nicht erfasst; Postings, die supersedet oder gecancelt +wurden, bleiben erfasst, sofern sie das System ueberhaupt (und vor der +Loeschnachricht) erreicht haben. +HOSTSOUT + +##### ----- subroutines ---------------------------------------------- + +sub Percentage { +# calculate percentage rate from base value and percentage + my ($Base,$Percentage) = @_; + return ($Percentage * 100 / $Base); +} + +sub Divider { +# build a divider line of $Symbol as wide as the table is + my ($Symbol,$MaxLength) = @_; + return ':' . $Symbol x ($MaxLength+TABLEWIDTH) . ":\n"; +} + +##### ----- main loop ------------------------------------------------ + +my (%Value, $SumName, $SumTotal, $MaxLength); +$MaxLength = 0; +if ($Type eq 'GroupStats') { + $SumName = "$TLH.ALL"; + $TH{'name'} = 'Newsgroup' +} elsif ($Type eq 'HostStats') { + $SumName = 'ALL'; + $TH{'name'} = 'Server' +} + +# read from STDIN +while(<>) { + my ($Name, $Value) = split; + $SumTotal = $Value if $Name eq $SumName; + next if $Name =~ /ALL$/; + $Value{$Name} = $Value; + $MaxLength = length($Name) if length($Name) > $MaxLength; +} + +# print to STDOUT +my $PaddingLeft = ' ' x int((($MaxLength+TABLEWIDTH-2-length($Heading{$Type}))/2)); +my $PaddingRight = $PaddingLeft; +$PaddingLeft .= ' ' if (length($Heading{$Type}) + (length($PaddingLeft) * 2) < $MaxLength+TABLEWIDTH); +my $Counter = 0; + +print $LeadIn{$Type}; + +print &Divider('=',$MaxLength); +printf(": %s%s%s :\n",$PaddingLeft,$Heading{$Type},$PaddingRight); +print &Divider('=',$MaxLength); +printf(": %-3s : %-6s : %-7s : %-*s :\n", + substr($TH{'counter'},0,3), + substr($TH{'value'},0,6), + substr($TH{'percentage'},0,7), + $MaxLength,$TH{'name'}); +print &Divider('-',$MaxLength); + +foreach my $Name (sort { $Value{$b} <=> $Value {$a}} keys %Value) { + $Counter++; + printf(": %3u. : %6u : %6.2f%% : %-*s :\n",$Counter,$Value{$Name},&Percentage($SumTotal,$Value{$Name}),$MaxLength,$Name); +} + +print &Divider('-',$MaxLength); +printf(": : %6u : %s : %-*s :\n",$SumTotal,'100.00%',$MaxLength,''); +print &Divider('=',$MaxLength); + +print $LeadOut{$Type}; + +__END__ + +################################ Documentation ################################# + +=head1 NAME + +postingstats - format and post reports + +=head1 SYNOPSIS + +B B<-t> I [B<-Vh> [B<-m> I] + +=head1 REQUIREMENTS + +See L. + +=head1 DESCRIPTION + +This script will re-format reports on newsgroup usage created by +B or B and create a message that can +be posted to Usenet. + +=head2 Features and options + +B will create a table with entries numbered from most +to least and percentages calculated from the sum total of all values. + +It depends on a sorted list on STDIN in I format with I. + +B needs a B<--type> and a B<--month> to create a caption +and select matching lead-ins and lead-outs. B<--type> is also needed +to catch the correct sum total from input. + +It will default to posting statistics (number of postings per group) +and last month. + +Output from B can be piped to any C implementation, +e.g. C from L +(present in C). + +=head2 Configuration + +Configuration is done by changing the code in the +C<----- configuration -----> section. + +=over 3 + +=item C<$TLH> + +Top level hierarchy the report was created for. Used for display and +sum total. + +=item C<%Heading> + +Hash with keys for I and I. Used to display a +heading. + +=item C<%TH> + +Hash with keys for I, I and I. Used to +create the table header for I, I and I. + +I must not be longer than 3 characters, I no longer +than 6 characters and I no longer than 7 characters. +Output will be truncated otherwise. + +=item C<%LeadIn> + +Hash with keys for I and I. Used to create the +headers for our posting. Can contain other text that will be shown +before C<%Heading>. + +=item C<%LeadOut> + +Hash with keys for I and I. Will be shown at the +end of our posting. + +=back + +=head1 OPTIONS + +=over 3 + +=item B<-V>, B<--version> + +Print out version and copyright information and exit. + +=item B<-h>, B<--help> + +Print this man page and exit. + +=item B<-t>, B<--type> I + +Set report type to posting statistics or hosts statistics accordingly. + +=item B<-m>, B<--month> I + +Set month for display. + +=back + +=head1 INSTALLATION + +See L. + +=head1 USAGE + +Create a posting from a posting statistics report for last month: + + groupstats.pl --nocomments --sums --format dump | postingstats.pl -t groups + +Create a posting from a posting statistics report for 2012-01: + + groupstats.pl --nocomments --sums --format dump | postingstats.pl -t groups -m 2012-01 + +Create a posting from a host statistics report for last month: + + cliservstats.pl -t server --nocomments --sums --format dump | postingstats.pl -t hosts + +=head1 FILES + +=over 4 + +=item F + +The script itself. + +=item F + +Library functions for the NewsStats package. + +=item F + +Runtime configuration file. + +=back + +=head1 BUGS + +Please report any bugs or feature requests to the author or use the +bug tracker at L! + +=head1 SEE ALSO + +=over 2 + +=item - + +L + +=item - + +l>doc/INSTALL> + +=item - + +groupstats -h + +=item - + +cliservstats -h + +=back + +This script is part of the B package. + +=head1 AUTHOR + +Thomas Hochstein + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2010-2012, 2025 Thomas Hochstein + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/contrib/dopostingstats.sh b/contrib/dopostingstats.sh new file mode 100644 index 0000000..30ef8f1 --- /dev/null +++ b/contrib/dopostingstats.sh @@ -0,0 +1,9 @@ +#!/bin/bash +# installation path is /srv/newsstats/, please adjust accordingly +if [[ $1 =~ [0-9]{4}-[0-9]{2} ]]; then + /srv/newsstats/bin/groupstats.pl --nocomments --sums --format dump --month $1 | /srv/newsstats/bin/postingstats.pl --month $1 | /srv/newsstats/contrib/tinews.pl -X -Y + /srv/newsstats/bin/cliservstats.pl -t server --nocomments --sums --format dump --month $1 | /srv/newsstats/bin/postingstats.pl -t server --month $1 | /srv/newsstats/contrib/tinews.pl -X -Y +else + echo 'Input error, please use dopostingstats.sh YYYY-MM' +fi + diff --git a/contrib/tinews.pl b/contrib/tinews.pl new file mode 100644 index 0000000..b90199e --- /dev/null +++ b/contrib/tinews.pl @@ -0,0 +1,1506 @@ +#! /usr/bin/perl +# +# reads an article on STDIN, mails any copies if required, +# signs the article and posts it. +# +# +# Copyright (c) 2002-2024 Urs Janssen , +# Marc Brockschmidt +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions +# are met: +# +# 1. Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# 3. Neither the name of the copyright holder nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# +# TODO: - extend debug mode to not delete tmp-files and be more verbose +# - add pid to pgptmpf to allow multiple simultaneous instances +# - check for /etc/nntpserver (and /etc/news/server) +# - add $PGPOPTS, $PGPPATH and $GNUPGHOME support +# - cleanup and remove duplicated code +# - quote inpupt properly before passing to shell +# - $ENV{'NEWSHOST'} / $ENV{'NNTPSERVER'} and $ENV{'NNTPPORT'} +# do have higher precedence than settings in the script and +# config-file, but config-settig SSL may override $ENV{'NNTPPORT'} +# - if (!defined $ENV{'GPG_TTY'}) {if (open(my $T,'-|','tty')) { +# chomp(my $tty=<$T>); close($T); +# $ENV{'GPG_TTY'}=$tty if($tty =~ m/^\//)}} +# for gpg? +# - option to break long header lines? +# - option to trim References +# - option to foce connection via AF_INET6 (-6) +# ... +# +# cmd-line options used in other inews: +# inews-xt (Olaf Titz): +# -C accepted for historic reasons and errors out +# inews (inn) +# -P don't add Sender +# inews (Eric S. Raymond; 1989) +# -C create grp +# -d Distribution: +# -p [file] ; run rnews mode +# -M moderator option +# -v print returned ID + +require 5.004; + +use strict; +use warnings; + +# version Number +my $version = "1.1.70"; + +my %config; + +# configuration, may be overwritten via ~/.tinewsrc +$config{'nntp-server'} = 'news'; # your NNTP servers name, may be set via $NNTPSERVER +$config{'nntp-port'} = 119; # NNTP-port, may be set via $NNTPPORT +$config{'nntp-user'} = ''; # username for nntp-auth, may be set via ~/.newsauth or ~/.nntpauth +$config{'nntp-pass'} = ''; # password for nntp-auth, may be set via ~/.newsauth or ~/.nntpauth + +$config{'ssl'} = 0; # set to 1 to use NNTPS if possible + +$config{'pgp-signer'} = ''; # sign as who? +$config{'pgp-pass'} = ''; # pgp2 only +$config{'path-to-pgp-pass'}= ''; # pgp2, pgp5, pgp6 and gpg +$config{'pgp-pass-fd'} = 9; # file descriptor used for input redirection of path-to-pgp-pass; GPG1, GPG2, PGP5 and PGP6 only + +$config{'pgp'} = '/usr/bin/pgp'; # path to pgp +$config{'pgp-version'} = '2'; # Use 2 for 2.X, 5 for PGP5, 6 for PGP6, GPG or GPG1 for GPG1 and GPG2 for GPG2 +$config{'digest-algo'} = 'MD5';# Digest Algorithm for GPG. Must be supported by your installation + +$config{'interactive'} = 'yes';# allow interactive usage + +$config{'verbose'} = 0; # set to 1 to get warning messages +$config{'debug'} = 0; # set to 1 to get some debug output + +$config{'sig-path'} = glob('~/.signature'); # path to signature +$config{'add-signature'}= 'yes';# Add $config{'sig-path'} to posting if there is no sig +$config{'sig-max-lines'}= 4; # max number of signatures lines + +$config{'max-header-length'} = 998; # RFC 5536 + +$config{'sendmail'} = '/usr/sbin/sendmail -i -t'; # set to '' to disable mail-actions + +$config{'pgptmpf'} = 'pgptmp'; # temporary file for PGP. + +$config{'pgpheader'} = 'X-PGP-Sig'; +$config{'pgpbegin'} = '-----BEGIN PGP SIGNATURE-----'; # Begin of PGP-Signature +$config{'pgpend'} = '-----END PGP SIGNATURE-----'; # End of PGP-Signature + +$config{'canlock-algorithm'} = 'sha1'; # Digest algorithm used for cancel-lock and cancel-key; sha1, sha256 and sha512 are supported +# $config{'canlock-secret'} = '~/.cancelsecret'; # Path to canlock secret file + +# $config{'ignore-headers'} = ''; # headers to be ignored during signing + +$config{'pgp-sign-headers'} = [ + 'From', 'Newsgroups', 'Subject', 'Control', 'Supersedes', 'Followup-To', + 'Date', 'Injection-Date', 'Sender', 'Approved', 'Message-ID', 'Reply-To', + 'Cancel-Key', 'Also-Control', 'Distribution' ]; +$config{'pgp-order-headers'} = [ + 'from', 'newsgroups', 'subject', 'control', 'supersedes', 'followup-To', + 'date', 'injection-date', 'organization', 'lines', 'sender', 'approved', + 'distribution', 'message-id', 'references', 'reply-to', 'mime-version', + 'content-type', 'content-transfer-encoding', 'summary', 'keywords', + 'cancel-lock', 'cancel-key', 'also-control', 'x-pgp', 'user-agent' ]; + +################################################################################ + +use Getopt::Long qw(GetOptions); +use Net::NNTP; +use IO::Socket qw(AF_INET PF_INET); +use Time::Local; +use Term::ReadLine; + +(my $pname = $0) =~ s#^.*/##; + +# read config file (first match counts) from +# $XDG_CONFIG_HOME/tinewsrc +# ~/.config/tinewsrc +# ~/.tinewsrc +# if present +my $TINEWSRC = undef; +my (@try, %seen); + +if ($ENV{'XDG_CONFIG_HOME'}) { + push(@try, (glob("$ENV{'XDG_CONFIG_HOME'}/tinewsrc"))[0]); +} +push(@try, (glob('~/.config/tinewsrc'))[0], (glob('~/.tinewsrc'))[0]); + +foreach (grep { ! $seen{$_}++ } @try) { # uniq @try + last if (open($TINEWSRC, '<', $_)); + $TINEWSRC = undef; +} +if (defined($TINEWSRC)) { + my $changes = 0; + while (defined($_ = <$TINEWSRC>)) { + if (m/^([^#\s=]+)\s*=\s*(\S[^#]+)/io) { + # rename pre 1.1.56 tinewsrc-var names + my $key = $1; + my $val = $2; + $key =~ s#^followupto#follow-to# && $changes++; + $key =~ s#^replyto#reply-to# && $changes++; + $key =~ s#^NNTP(?!\-).#NNTP-# && $changes++; + $key =~ s#^PathtoPGPPass#path-to-pgp-pass# && $changes++; + $key =~ s#^PGPorderheaders#pgp-order-headers# && $changes++; + $key =~ s#^PGPPassFD#pgp-pass-fd# && $changes++; + $key =~ s#^PGPSignHeaders#pgp-sign-headers# && $changes++; + $key =~ s#^PGP(?!\-).#PGP-# && $changes++; + $key =~ s#_#-# && $changes++; + chomp($config{lc($key)} = $val); + } + } + close($TINEWSRC); + print "Old style tinewsrc option names found, you should adjust them.\n" if ($changes && ($config{'verbose'} || $config{'debug'})); +} + +# as of tinews 1.1.51 we use 3 args open() to pipe to sendmail +# thus we remove any leading '|' to avoid syntax errors; +# for redirections use cat etc.pp., eg. 'cat > /tmp/foo' +$config{'sendmail'} =~ s/^\s*\|\s*//io; + +# digest-algo is case sensitive and should be all uppercase +$config{'digest-algo'} = uc($config{'digest-algo'}); + +# these env-vars have higher priority (order is important) +$config{'nntp-server'} = $ENV{'NEWSHOST'} if ($ENV{'NEWSHOST'}); +$config{'nntp-server'} = $ENV{'NNTPSERVER'} if ($ENV{'NNTPSERVER'}); +$config{'nntp-port'} = $ENV{'NNTPPORT'} if ($ENV{'NNTPPORT'}); + +# Get options +Getopt::Long::Configure ("bundling", "no_ignore_case"); +my $oret = GetOptions( + 'A|V|W|h|headers' => [], # do nothing + 'debug|D|N' => \$config{'debug'}, + 'port|p=i' => \$config{'nntp-port'}, + 'no-sign|X' => \$config{'no-sign'}, + 'no-control|R' => \$config{'no-control'}, + 'no-signature|S' => \$config{'no-signature'}, + 'no-canlock|L' => \$config{'no-canlock'}, + 'no-injection-date|I' => \$config{'no-injection-date'}, + 'no-organization|O' => \$config{'no-organization'}, + 'force-auth|Y' => \$config{'force-auth'}, + 'approved|a=s' => \$config{'approved'}, + 'control|c=s' => \$config{'control'}, + 'canlock-algorithm=s' => \$config{'canlock-algorithm'}, + 'distribution|d=s' => \$config{'distribution'}, + 'discard-empty|E' => \$config{'discard-empty'}, + 'expires|e=s' => \$config{'expires'}, + 'from|f=s' => \$config{'from'}, + 'ignore-headers|i=s' => \$config{'ignore-headers'}, + 'followup-to|w=s' => \$config{'followup-to'}, + 'message-id|m=s' => \$config{'message-id'}, + 'newsgroups|n=s' => \$config{'newsgroups'}, + 'reply-to|r=s' => \$config{'reply-to'}, + 'savedir|s=s' => \$config{'savedir'}, + 'ssl|nntps' => \$config{'ssl'}, + 'subject|t=s' => \$config{'subject'}, + 'references|F=s' => \$config{'references'}, + 'organization|o=s' => \$config{'organization'}, + 'path|x=s' => \$config{'path'}, + 'timeout|T=i' => \$config{'timeout'}, + 'ipv4|4' => \$config{'ipv4'}, + 'help|H' => \$config{'help'}, + 'transform' => \$config{'transform'}, + 'verbose|v' => \$config{'verbose'}, + 'version' => \$config{'version'}, + 'man' => \$config{'man'} +); + +usage() unless $oret; + +if ($config{'version'}) { + version(); + exit 0; +} + +usage() if ($config{'help'}); + +# not listed in usage() or man-page as it may not work +if ($config{'man'}) { + if (eval { require Pod::Usage;1; } != 1) { + $config{'man'} = 0; + print STDERR "Unknown option: man.\n"; + usage(); + } else { + use Pod::Usage; + pod2usage(-verbose => 3, -exit => 0); + } +} + +# check if SSL support is available +if ($config{'ssl'}) { + eval "Net::NNTP->can_ssl"; + if ($@) { + warn "Your Net::NNTP doesn't support SSL.\n" if ($config{'debug'} || $config{'verbose'}); + $config{'ssl'} = 0; + } +} + +# and now adjust default port depending on SSL requested and +# available or not +if ($config{'ssl'}) { + $config{'nntp-port'} = 563 if ($config{'nntp-port'} == 119); +} else { + $config{'nntp-port'} = 119 if ($config{'nntp-port'} == 563); +} + +# Cancel-Locks require some more modules +my $sha_mod = undef; +if ($config{'canlock-secret'} && !$config{'no-canlock'}) { + $config{'canlock-algorithm'} = lc($config{'canlock-algorithm'}); + # we support sha1, sha256 and sha512, fallback to sha1 if something else is given + if (!($config{'canlock-algorithm'} =~ /^sha(1|256|512)$/)) { + warn "Digest algorithm " . $config{'canlock-algorithm'} . " not supported. Falling back to sha1.\n" if ($config{'debug'} || $config{'verbose'}); + $config{'canlock-algorithm'} = 'sha1'; + } + if ($config{'canlock-algorithm'} eq 'sha1') { + foreach ('Digest::SHA qw(sha1)', 'Digest::SHA1()') { + eval "use $_"; + if (!$@) { + ($sha_mod = $_) =~ s#( qw\(sha1\)|\(\))##; + last; + } + } + foreach ('MIME::Base64()', 'Digest::HMAC_SHA1()') { + eval "use $_"; + if ($@ || !defined($sha_mod)) { + $config{'no-canlock'} = 1; + warn "Cancel-Locks disabled: Can't locate ".$_." (".__FILE__.":".__LINE__.")\n" if ($config{'debug'} || $config{'verbose'}); + last; + } + } + } elsif ($config{'canlock-algorithm'} eq 'sha256') { + foreach ('MIME::Base64()', 'Digest::SHA qw(sha256 hmac_sha256)') { + eval "use $_"; + if ($@) { + $config{'no-canlock'} = 1; + warn "Cancel-Locks disabled: Can't locate ".$_." (".__FILE__.":".__LINE__.")\n" if ($config{'debug'} || $config{'verbose'}); + last; + } + } + } else { + foreach ('MIME::Base64()', 'Digest::SHA qw(sha512 hmac_sha512)') { + eval "use $_"; + if ($@) { + $config{'no-canlock'} = 1; + warn "Cancel-Locks disabled: Can't locate ".$_." (".__FILE__.":".__LINE__.")\n" if ($config{'debug'} || $config{'verbose'}); + last; + } + } + } +} + +my $term = Term::ReadLine->new('tinews'); +my $attribs = $term->Attribs; +my $in_header = 1; +my (%Header, @Body, $PGPCommand); + +if (! $config{'no-sign'}) { + $config{'pgp-signer'} = $ENV{'SIGNER'} if ($ENV{'SIGNER'}); + $config{'path-to-pgp-pass'} = $ENV{'PGPPASSFILE'} if ($ENV{'PGPPASSFILE'}); + if ($config{'path-to-pgp-pass'}) { + open(my $pgppass, '<', (glob($config{'path-to-pgp-pass'}))[0]) or + $config{'interactive'} && die("$0: Can't open ".$config{'path-to-pgp-pass'}.": $!"); + chomp($config{'pgp-pass'} = <$pgppass>); + close($pgppass); + } + if ($config{'pgp-version'} eq '2' && $ENV{'PGPPASS'}) { + $config{'pgp-pass'} = $ENV{'PGPPASS'}; + } +} + +# Remove unwanted headers from pgp-sign-headers +if (${config{'ignore-headers'}}) { + my @hdr_to_ignore = split(/,/, ${config{'ignore-headers'}}); + foreach my $hdr (@hdr_to_ignore) { + @{$config{'pgp-sign-headers'}} = map {lc($_) eq lc($hdr) ? () : $_} @{$config{'pgp-sign-headers'}}; + } +} + +# Read the message and split the header +readarticle(\%Header, \@Body); + +# empty @Body +if (scalar @Body == 0) { + warn("Empty article\n") if ($config{'verbose'}); + exit 0 if ($config{'discard-empty'}); +} + +# Add signature if there is none +if (!$config{'no-signature'}) { + if ($config{'add-signature'} && !grep {/^-- /} @Body) { + if (-r glob($config{'sig-path'})) { + my $l = 0; + push @Body, "-- \n"; + open(my $SIGNATURE, '<', glob($config{'sig-path'})) or die("Can't open " . $config{'sig-path'} . ": $!"); + while (<$SIGNATURE>) { + die $config{'sig-path'} . " longer than " . $config{'sig-max-lines'}. " lines!" if (++$l > $config{'sig-max-lines'}); + push @Body, $_; + } + close($SIGNATURE); + } else { + warn "Tried to add " . $config{'sig-path'} . ", but it is unreadable.\n" if ($config{'debug'} || $config{'verbose'}); + } + } +} + +# import headers set in the environment +if (!defined($Header{'reply-to'})) { + if ($ENV{'REPLYTO'}) { + chomp($Header{'reply-to'} = "Reply-To: " . $ENV{'REPLYTO'}); + $Header{'reply-to'} .= "\n"; + } +} +foreach ('DISTRIBUTION', 'ORGANIZATION') { + if (!defined($Header{lc($_)}) && $ENV{$_}) { + chomp($Header{lc($_)} = ucfirst($_).": " . $ENV{$_}); + $Header{lc($_)} .= "\n"; + } +} + +# overwrite headers if specified via cmd-line +foreach ('Approved', 'Control', 'Distribution', 'Expires', + 'From', 'Followup-To', 'Message-ID', 'Newsgroups', 'Reply-To', + 'Subject', 'References', 'Organization') { + next if (!defined($config{lc($_)})); + chomp($Header{lc($_)} = $_ . ": " . $config{lc($_)}); + $Header{lc($_)} .= "\n"; +} + +# -x doesn't overwrite but prefixes +if (defined($config{'path'})) { + if (defined($Header{'path'})) { + (my $pbody = $Header{'path'}) =~ s#^Path: ##i; + chomp($Header{'path'} = "Path: " . $config{'path'} . "!" . $pbody); + } else { + chomp($Header{'path'} = "Path: " . $config{'path'}); + } + $Header{'path'} .= "\n"; +} + +# verify/add/remove headers +foreach ('From', 'Subject') { + die("$0: No $_:-header defined.") if (!defined($Header{lc($_)})); +} + +$Header{'date'} = "Date: ".getdate()."\n" if (!defined($Header{'date'}) || $Header{'date'} !~ m/^[^\s:]+: .+/o); +$Header{'injection-date'} = "Injection-Date: ".getdate()."\n" if (!$config{'no-injection-date'}); + +if (defined($Header{'user-agent'})) { + chomp $Header{'user-agent'}; + $Header{'user-agent'} = $Header{'user-agent'}." ".$pname."/".$version."\n"; +} + +delete $Header{'x-pgp-key'} if (!$config{'no-sign'} && defined($Header{'x-pgp-key'})); + +delete $Header{'organization'} if ($config{'no-organization'} && defined($Header{'organization'})); + +# No control. No control. You have no control. +if ($config{'no-control'} and $Header{control}) { + print STDERR "No control messages allowed.\n"; + exit 1; +} + +# various checks +if ($config{'debug'} || $config{'verbose'}) { + foreach (keys %Header) { + warn "Raw 8-bit data in the following header:\n$Header{$_}\n" if ($Header{$_} =~ m/[\x80-\xff]/o); + } + # do not check for CTE as it's not required for miltipart/* + if (!defined($Header{'mime-version'}) || !defined($Header{'content-type'})) { + warn "8bit body without MIME-headers\n" if (grep {/[\x80-\xff]/} @Body); + } +} + +# try ~/.newsauth if no $config{'nntp-pass'} was set +if (!$config{'nntp-pass'}) { + my ($l, $server, $pass, $user); + if (-r (glob("~/.newsauth"))[0]) { + open (my $NEWSAUTH, '<', (glob("~/.newsauth"))[0]) or die("Can't open ~/.newsauth: $!"); + while ($l = <$NEWSAUTH>) { + next if ($l =~ m/^([#\s]|$)/); + chomp $l; + $user = $pass = $server = undef; + if ($l =~ m/^ + (\S+)\s+ # server + ("(?:[^"]+)"|(?:\S+)) # password + \s+("(?:[^"]+)"|(?:\S+)) # user + /x) { + $server = $1; + $pass = $2; + $user = $3; + if ($pass =~ m/^"([^"]+)"/) { # strip enclising " + $pass = $1; + } + if ($user =~ m/^"([^"]+)"/) { # likewise + $user = $1; + } + } else { # server passwrd + if ($l =~ m/^(\S+)\s+("(?:[^"]+)"|(?:\S+))/) { + $server = $1; + $pass = $2; + if ($pass =~ m/^"([^"]+)"/) { # likewise + $pass = $1; + } + } + } + last if ($server =~ m/\Q$config{'nntp-server'}\E/); + } + close($NEWSAUTH); + if ($pass && $server =~ m/\Q$config{'nntp-server'}\E/) { + $config{'nntp-pass'} = $pass; + $config{'nntp-user'} = $user || getlogin || getpwuid($<) || $ENV{USER}; + } else { + $pass = $user = ""; + } + } + # try ~/.nntpauth if we still got no password + if (!$pass) { + if (-r (glob("~/.nntpauth"))[0]) { + open (my $NNTPAUTH, '<', (glob("~/.nntpauth"))[0]) or die("Can't open ~/.nntpauth: $!"); + while ($l = <$NNTPAUTH>) { + chomp $l; + next if ($l =~ m/(^[#\s]|)/); + ($server, $user, $pass) = split(/\s+\b/, $l); + last if ($server =~ m/\Q$config{'nntp-server'}\E/); + } + close($NNTPAUTH); + if ($pass && $server =~ m/\Q$config{'nntp-server'}\E/) { + $config{'nntp-pass'} = $pass; + $config{'nntp-user'} = $user || getlogin || getpwuid($<) || $ENV{USER}; + } + } + } +} + +# instead of abort posting just to prefetch a Messsage-ID we should (try +# to) keep the session open instead +if (!($config{'no-sign'} && $config{'no-canlock'})) { + if (! $config{'savedir'} && defined($Header{'newsgroups'}) && !defined($Header{'message-id'})) { + my $Server = AuthonNNTP(); + my $ServerMsg = $Server->message(); + $Header{'message-id'} = "Message-ID: $1\n" if ($ServerMsg =~ m/(<\S+\@\S+>)/o); + #$Server->datasend('.'); # dataend() already sends "." + $Server->dataend(); + $Server->quit(); + } + + if (!defined($Header{'message-id'})) { + my $hname; + if (eval { require Sys::Hostname;1; } != 1) { + chomp($hname = `hostname`); + } else { + use Sys::Hostname; + $hname = hostname(); + } + my ($hostname,) = gethostbyname($hname); + if (defined($hostname) && $hostname =~ m/\./io) { + $Header{'message-id'} = "Message-ID: " . sprintf("\n", $>, timelocal(localtime), $$, $hostname); + } + } +} + +# add Cancel-Lock (and Cancel-Key) header(s) if requested +if ($config{'canlock-secret'} && !$config{'no-canlock'} && defined($Header{'message-id'})) { + open(my $CANLock, '<', (glob($config{'canlock-secret'}))[0]) or die("$0: Can't open " . $config{'canlock-secret'} . ": $!"); + chomp(my $key = <$CANLock>); + close($CANLock); + (my $data = $Header{'message-id'}) =~ s#^Message-ID: ##i; + chomp $data; + my $cancel_key = buildcancelkey($data, $key); + my $cancel_lock = buildcancellock($cancel_key, $sha_mod); + if (defined($Header{'cancel-lock'})) { + chomp $Header{'cancel-lock'}; + $Header{'cancel-lock'} .= " " . $config{'canlock-algorithm'} . ":" . $cancel_lock . "\n"; + } else { + $Header{'cancel-lock'} = "Cancel-Lock: " . $config{'canlock-algorithm'} . ":" . $cancel_lock . "\n"; + } + + if ((defined($Header{'supersedes'}) && $Header{'supersedes'} =~ m/^Supersedes:\s+<\S+>\s*$/i) || (defined($Header{'control'}) && $Header{'control'} =~ m/^Control:\s+cancel\s+<\S+>\s*$/i) ||(defined($Header{'also-control'}) && $Header{'also-control'} =~ m/^Also-Control:\s+cancel\s+<\S+>\s*$/i)) { + if (defined($Header{'also-control'}) && $Header{'also-control'} =~ m/^Also-Control:\s+cancel\s+/i) { + ($data = $Header{'also-control'}) =~ s#^Also-Control:\s+cancel\s+##i; + chomp $data; + $cancel_key = buildcancelkey($data, $key); + } else { + if (defined($Header{'control'}) && $Header{'control'} =~ m/^Control: cancel /i) { + ($data = $Header{'control'})=~ s#^Control:\s+cancel\s+##i; + chomp $data; + $cancel_key = buildcancelkey($data, $key); + } else { + if (defined($Header{'supersedes'})) { + ($data = $Header{'supersedes'}) =~ s#^Supersedes: ##i; + chomp $data; + $cancel_key = buildcancelkey($data, $key); + } + } + } + if (defined($Header{'cancel-key'})) { + chomp $Header{'cancel-key'}; + $Header{'cancel-key'} .= " " . $config{'canlock-algorithm'} . ":" . $cancel_key . "\n"; + } else { + $Header{'cancel-key'} = "Cancel-Key: " . $config{'canlock-algorithm'} . ":" . $cancel_key . "\n"; + } + } +} + +# set Posted-And-Mailed if we send a mailcopy to someone else +if ($config{'sendmail'} && defined($Header{'newsgroups'}) && (defined($Header{'to'}) || defined($Header{'cc'}) || defined($Header{'bcc'}))) { + foreach ('to', 'bcc', 'cc') { + if (defined($Header{$_}) && $Header{$_} ne $Header{'from'}) { + $Header{'posted-and-mailed'} = "Posted-And-Mailed: yes\n"; + last; + } + } +} + +if (! $config{'no-sign'}) { + if (!$config{'pgp-signer'}) { + chomp($config{'pgp-signer'} = $Header{'from'}); + $config{'pgp-signer'} =~ s/^[^\s:]+: (.*)/$1/; + } + $PGPCommand = getpgpcommand($config{'pgp-version'}); +} + +# exit with error if neither $Newsgroups nor any of $To, $Cc or $Bcc are set +my $required = 0; +foreach ('Newsgroups', 'To', 'Cc', 'Bcc') { + $required++ if (defined($Header{lc($_)})); + last if $required; +} +die("$0: neither Newsgroups: nor any of To:, Cc:, or Bcc: present.\n") if (!$required); + +# (re)move mail-headers +my ($To, $Cc, $Bcc, $Newsgroups) = ''; +$To = $Header{'to'} if (defined($Header{'to'})); +$Cc = $Header{'cc'} if (defined($Header{'cc'})); +$Bcc = $Header{'bcc'} if (defined($Header{'bcc'})); +delete $Header{$_} foreach ('to', 'cc', 'bcc'); +$Newsgroups = $Header{'newsgroups'} if (defined($Header{'newsgroups'})); + +my $MessageR = []; + +if ($config{'no-sign'}) { + # don't sign article + push @$MessageR, $Header{$_} for (keys %Header); + push @$MessageR, "\n", @Body; +} else { + # sign article + $MessageR = signarticle(\%Header, \@Body); +} + +# post or save article +if (! $config{'savedir'}) { + postarticle($MessageR) if ($Newsgroups); +} else { + savearticle($MessageR) if ($Newsgroups); +} + +# mail article +if (($To || $Cc || $Bcc) && $config{'sendmail'}) { + open(my $MAIL, '|-', $config{'sendmail'}) || die("$!"); + unshift @$MessageR, "$To" if ($To); + unshift @$MessageR, "$Cc" if ($Cc); + unshift @$MessageR, "$Bcc" if ($Bcc); + print($MAIL @$MessageR); + + close($MAIL); +} + +# Game over. Insert new coin. +exit; + + +#-------- sub readarticle +# +sub readarticle { + my ($HeaderR, $BodyR) = @_; + my $currentheader; + my $l = 0; + while (defined($_ = <>)) { + s#\r\n$#\n# if ($config{'transform'}); + if ($in_header) { + use bytes; + if (m/^$/o) { #end of header + $in_header = 0; + } elsif (m/^([^\s:]+): (.*)$/s) { + $currentheader = lc($1); + $$HeaderR{$currentheader} = "$1: $2"; + $l = length($_); + print "" . $1 . ":-header exceeds line length limit " . $l . " > " . $config{'max-header-length'} . " octets.\n" if (($config{'verbose'} || $config{'debug'}) && length($_) > $config{'max-header-length'}); + } elsif (m/^[ \t]/o) { + $$HeaderR{$currentheader} .= $_; + $l = length($_); + print "Part of continued " . ucfirst($currentheader) . ":-header exceeds line length limit " . $l . " > " . $config{'max-header-length'} . " octets.\n" if (($config{'verbose'} || $config{'debug'}) && $l > $config{'max-header-length'}); +# } elsif (m/^([^\s:]+):$/) { # skip over empty headers +# next; + } else { + chomp($_); + # TODO: quote esc. sequences? + die("'$_' is not a correct header-line"); + } + } else { + push @$BodyR, $_; + } + } + return; +} + +#-------- sub getdate +# getdate generates a date and returns it. +# +sub getdate { + my @time = localtime; + my $ss = ($time[0]<10) ? "0".$time[0] : $time[0]; + my $mm = ($time[1]<10) ? "0".$time[1] : $time[1]; + my $hh = ($time[2]<10) ? "0".$time[2] : $time[2]; + my $day = $time[3]; +# my $month = ($time[4]+1 < 10) ? "0".($time[4]+1) : $time[4]+1; # 01...12; unused + my $monthN = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")[$time[4]]; + my $wday = ("Sun","Mon","Tue","Wed","Thu","Fri","Sat")[$time[6]]; + my $year = $time[5] + 1900; + my $offset = timelocal(localtime) - timelocal(gmtime); + my $sign ="+"; + if ($offset < 0) { + $sign ="-"; + $offset *= -1; + } + my $offseth = int($offset/3600); + my $offsetm = int(($offset - $offseth*3600)/60); + my $tz = sprintf("%s%0.2d%0.2d", $sign, $offseth, $offsetm); + return "$wday, $day $monthN $year $hh:$mm:$ss $tz"; +} + + +#-------- sub AuthonNNTP +# AuthonNNTP opens the connection to a Server and returns a Net::NNTP-Object. +# +# User, Password and Server are defined before as elements +# of the global hash %config. If no values for user or password +# are defined, the sub will try to ask the user (only if +# $config{'interactive'} is != 0). +sub AuthonNNTP { + my $Server = Net::NNTP->new( + Host => $config{'nntp-server'}, + Reader => 1, + Debug => $config{'debug'}, + Port => $config{'nntp-port'}, + Timeout => $config{'timeout'}, + Domain => ($config{'ipv4'} ? AF_INET : undef), + SSL => $config{'ssl'}, + SSL_verify_mode => 0 + ) or die("$0: Can't connect to ".$config{'nntp-server'}.":".$config{'nntp-port'}."!\n"); + if ($config{'debug'}) { + printf("Connected to : ".$Server->peerhost.":".$Server->peerport." [%s]\n", ($Server->sockdomain == PF_INET) ? "IPv4" : "IPv6"); + if ($config{'ssl'}) { + printf("SSL_fingerprint: %s %s\n", split(/\$/, $Server->get_fingerprint)); + } + } + my $ServerMsg = $Server->message(); + my $ServerCod = $Server->code(); + + # no read and/or write access - give up + if ($ServerCod < 200 || $ServerCod > 201) { + $Server->quit(); + die($0.": ".$ServerCod." ".$ServerMsg."\n"); + } + + # read access - try auth + if ($ServerCod == 201 || $config{'force-auth'}) { + if ($config{'nntp-pass'} eq "") { + if ($config{'interactive'}) { + $config{'nntp-user'} = $term->readline("Your Username at ".$config{'nntp-server'}.": "); + $attribs->{redisplay_function} = $attribs->{shadow_redisplay}; + $config{'nntp-pass'} = $term->readline("Password for ".$config{'nntp-user'}." at ".$config{'nntp-server'}.": "); + } else { + $Server->quit(); + die($0.": ".$ServerCod." ".$ServerMsg."\n"); + } + } + $Server->authinfo($config{'nntp-user'}, $config{'nntp-pass'}); + $ServerCod = $Server->code(); + $ServerMsg = $Server->message(); + if ($ServerCod != 281) { # auth failed + $Server->quit(); + die $0.": ".$ServerCod." ".$ServerMsg."\n"; + } + } + + $Server->post(); + $ServerCod = $Server->code(); + if ($ServerCod == 480) { + if ($config{'nntp-pass'} eq "") { + if ($config{'interactive'}) { + $config{'nntp-user'} = $term->readline("Your Username at ".$config{'nntp-server'}.": "); + $attribs->{redisplay_function} = $attribs->{shadow_redisplay}; + $config{'nntp-pass'} = $term->readline("Password for ".$config{'nntp-user'}." at ".$config{'nntp-server'}.": "); + } else { + $ServerMsg = $Server->message(); + $Server->quit(); + die($0.": ".$ServerCod." ".$ServerMsg."\n"); + } + } + $Server->authinfo($config{'nntp-user'}, $config{'nntp-pass'}); + $Server->post(); + } + return $Server; +} + + +#-------- sub getpgpcommand +# getpgpcommand generates the command to sign the message and returns it. +# +# Receives: +# - $pgpversion: A scalar holding the pgp-version +sub getpgpcommand { + my ($pgpversion) = @_; + my $found = 0; + + if ($config{'pgp'} !~ /^\//) { + foreach(split(/:/, $ENV{'PATH'})) { + if (-x $_."/".$config{'pgp'}) { + $found++; + last; + } + } + } + if (!-x $config{'pgp'} && ! $found) { + warn "PGP signing disabled: Can't locate executable ".$config{'pgp'}."\n" if ($config{'debug'} || $config{'verbose'}); + $config{'no-sign'} = 1; + } + + if ($pgpversion eq '2') { + if ($config{'pgp-pass'}) { + $PGPCommand = "PGPPASS=\"".$config{'pgp-pass'}."\" ".$config{'pgp'}." -z -u \"".$config{'pgp-signer'}."\" +verbose=0 language='en' -saft <".$config{'pgptmpf'}.".txt >".$config{'pgptmpf'}.".txt.asc"; + } elsif ($config{'interactive'}) { + $PGPCommand = $config{'pgp'}." -z -u \"".$config{'pgp-signer'}."\" +verbose=0 language='en' -saft <".$config{'pgptmpf'}.".txt >".$config{'pgptmpf'}.".txt.asc"; + } else { + die("$0: Passphrase is unknown!\n"); + } + } elsif ($pgpversion eq '5') { + if ($config{'path-to-pgp-pass'}) { + $PGPCommand = "PGPPASSFD=".$config{'pgp-pass-fd'}." ".$config{'pgp'}."s -u \"".$config{'pgp-signer'}."\" -t --armor -o ".$config{'pgptmpf'}.".txt.asc -z -f < ".$config{'pgptmpf'}.".txt ".$config{'pgp-pass-fd'}."<".$config{'path-to-pgp-pass'}; + } elsif ($config{'interactive'}) { + $PGPCommand = $config{'pgp'}."s -u \"".$config{'pgp-signer'}."\" -t --armor -o ".$config{'pgptmpf'}.".txt.asc -z -f < ".$config{'pgptmpf'}.".txt"; + } else { + die("$0: Passphrase is unknown!\n"); + } + } elsif ($pgpversion eq '6') { # this is untested + if ($config{'path-to-pgp-pass'}) { + $PGPCommand = "PGPPASSFD=".$config{'pgp-pass-fd'}." ".$config{'pgp'}." -u \"".$config{'pgp-signer'}."\" -saft -o ".$config{'pgptmpf'}.".txt.asc < ".$config{'pgptmpf'}.".txt ".$config{'pgp-pass-fd'}."<".$config{'path-to-pgp-pass'}; + } elsif ($config{'interactive'}) { + $PGPCommand = $config{'pgp'}." -u \"".$config{'pgp-signer'}."\" -saft -o ".$config{'pgptmpf'}.".txt.asc < ".$config{'pgptmpf'}.".txt"; + } else { + die("$0: Passphrase is unknown!\n"); + } + } elsif ($pgpversion =~ m/GPG1?$/io) { + if ($config{'path-to-pgp-pass'}) { + $PGPCommand = $config{'pgp'}." --emit-version --digest-algo $config{'digest-algo'} -a -u \"".$config{'pgp-signer'}."\" -o ".$config{'pgptmpf'}.".txt.asc --no-tty --batch --passphrase-fd ".$config{'pgp-pass-fd'}." ".$config{'pgp-pass-fd'}."<".$config{'path-to-pgp-pass'}." --clearsign ".$config{'pgptmpf'}.".txt"; + } elsif ($config{'interactive'}) { + $PGPCommand = $config{'pgp'}." --emit-version --digest-algo $config{'digest-algo'} -a -u \"".$config{'pgp-signer'}."\" -o ".$config{'pgptmpf'}.".txt.asc --no-secmem-warning --no-batch --clearsign ".$config{'pgptmpf'}.".txt"; + } else { + die("$0: Passphrase is unknown!\n"); + } + } elsif ($pgpversion =~ m/GPG2$/io) { + if ($config{'path-to-pgp-pass'}) { + $PGPCommand = $config{'pgp'}." --pinentry-mode loopback --emit-version --digest-algo $config{'digest-algo'} -a -u \"".$config{'pgp-signer'}."\" -o ".$config{'pgptmpf'}.".txt.asc --no-tty --batch --passphrase-fd ".$config{'pgp-pass-fd'}." ".$config{'pgp-pass-fd'}."<".$config{'path-to-pgp-pass'}." --clearsign ".$config{'pgptmpf'}.".txt"; + } elsif ($config{'interactive'}) { + $PGPCommand = $config{'pgp'}." --emit-version --digest-algo $config{'digest-algo'} -a -u \"".$config{'pgp-signer'}."\" -o ".$config{'pgptmpf'}.".txt.asc --no-secmem-warning --no-batch --clearsign ".$config{'pgptmpf'}.".txt"; + } else { + die("$0: Passphrase is unknown!\n"); + } + } else { + die("$0: Unknown PGP-Version $pgpversion!"); + } + return $PGPCommand; +} + + +#-------- sub postarticle +# postarticle posts your article to your Newsserver. +# +# Receives: +# - $ArticleR: A reference to an array containing the article +sub postarticle { + my ($ArticleR) = @_; + + my $Server = AuthonNNTP(); + my $ServerCod = $Server->code(); + my $ServerMsg = $Server->message(); + if ($ServerCod == 340) { + $Server->datasend(@$ArticleR); + ## buggy Net::Cmd < 2.31 + $Server->set_status(200, ""); + $Server->dataend(); + $ServerCod = $Server->code(); + $ServerMsg = $Server->message(); + if (! $Server->ok()) { + $Server->quit(); + die("\n$0: Posting failed! Response from news server:\n", $ServerCod, ' ', $ServerMsg); + } + $Server->quit(); + } else { + die("\n$0: Posting failed! Response from news server:\n", $ServerCod, ' ', $ServerMsg); + } + return; +} + + +#-------- sub savearticle +# savearticle saves your article to the directory $config{'savedir'} +# +# Receives: +# - $ArticleR: A reference to an array containing the article +sub savearticle { + my ($ArticleR) = @_; + my $timestamp = timelocal(localtime); + (my $ng = $Newsgroups) =~ s#^Newsgroups:\s*([^,\s]+).*#$1#i; + my $gn = join "", map { substr($_,0,1) } (split(/\./, $ng)); + my $filename = $config{'savedir'}."/".$timestamp."-".$gn."-".$$; + open(my $SH, '>', $filename) or die("$0: can't open $filename: $!\n"); + print $SH @$ArticleR; + close($SH) or warn "$0: Couldn't close: $!\n"; + return; +} + + +#-------- sub signarticle +# signarticle signs an article and returns a reference to an array +# containing the whole signed Message. +# +# Receives: +# - $HeaderR: A reference to a hash containing the articles headers. +# - $BodyR: A reference to an array containing the body. +# +# Returns: +# - $MessageRef: A reference to an array containing the whole message. +sub signarticle { + my ($HeaderR, $BodyR) = @_; + my (@pgp_head, @pgp_body, @sign_headers, $pgphead, $pgpbody, $signheaders); + + foreach (@{$config{'pgp-sign-headers'}}) { + if (defined($$HeaderR{lc($_)}) && $$HeaderR{lc($_)} =~ m/^[^\s:]+: .+/o) { + push @sign_headers, $_; + } + } + + $pgpbody = join("", @$BodyR); + + # Delete and create the temporary pgp-Files + unlink $config{'pgptmpf'}.".txt"; + unlink $config{'pgptmpf'}.".txt.asc"; + $signheaders = join(",", @sign_headers); + + $pgphead = "X-Signed-Headers: $signheaders\n"; + foreach my $header (@sign_headers) { + if ($$HeaderR{lc($header)} =~ m/^[^\s:]+: (.+?)\n?$/so) { + $pgphead .= $header.": ".$1."\n"; + } + } + + unless (substr($pgpbody, -1, 1) =~ /\n/) {$pgpbody .= "\n"}; + open(my $FH, '>', $config{'pgptmpf'} . ".txt") or die("$0: can't open ".$config{'pgptmpf'}.": $!\n"); + print $FH $pgphead, "\n", $pgpbody; + print $FH "\n" if ($config{'pgp-version'} =~ m/GPG/io); # workaround a pgp/gpg incompatibility - should IMHO be fixed in pgpverify + close($FH) or warn "$0: Couldn't close TMP: $!\n"; + + # Start PGP, then read the signature; + `$PGPCommand`; + + open($FH, '<', $config{'pgptmpf'} . ".txt.asc") or die("$0: can't open ".$config{'pgptmpf'}.".txt.asc: $!\n"); + local $/ = "\n".$config{'pgpbegin'}."\n"; + $_ = <$FH>; + unless (m/\Q$config{'pgpbegin'}\E$/o) { + unlink $config{'pgptmpf'} . ".txt"; + unlink $config{'pgptmpf'} . ".txt.asc"; + close($FH); + die("$0: ".$config{'pgpbegin'}." not found in ".$config{'pgptmpf'}.".txt.asc\n"); + } + unlink($config{'pgptmpf'} . ".txt") or warn "$0: Couldn't unlink ".$config{'pgptmpf'}.".txt: $!\n"; + + local $/ = "\n"; + $_ = <$FH>; + unless (m/^Version: (\S+)(?:\s(\S+))?/o) { + unlink $config{'pgptmpf'} . ".txt.asc"; + close($FH); + die("$0: didn't find PGP Version line where expected.\n"); + } + if (defined($2)) { + $$HeaderR{$config{'pgpheader'}} = $1."-".$2." ".$signheaders; + } else { + $$HeaderR{$config{'pgpheader'}} = $1." ".$signheaders; + } + do { # skip other pgp headers like + $_ = <$FH>; # "charset:"||"comment:" until empty line + } while ! /^$/; + + while (<$FH>) { + chomp; + last if /^\Q$config{'pgpend'}\E$/; + $$HeaderR{$config{'pgpheader'}} .= "\n\t$_"; + } + $$HeaderR{$config{'pgpheader'}} .= "\n" unless ($$HeaderR{$config{'pgpheader'}} =~ /\n$/s); + + $_ = <$FH>; + unless (eof($FH)) { + unlink $config{'pgptmpf'} . ".txt.asc"; + close($FH); + die("$0: unexpected data following ".$config{'pgpend'}."\n"); + } + close($FH); + unlink $config{'pgptmpf'} . ".txt.asc"; + + my $tmppgpheader = $config{'pgpheader'} . ": " . $$HeaderR{$config{'pgpheader'}}; + delete $$HeaderR{$config{'pgpheader'}}; + + @pgp_head = (); + foreach my $header (@{$config{'pgp-order-headers'}}) { + if ($$HeaderR{$header} && $$HeaderR{$header} ne "\n") { + push(@pgp_head, "$$HeaderR{$header}"); + delete $$HeaderR{$header}; + } + } + + foreach my $header (keys %$HeaderR) { + if ($$HeaderR{$header} && $$HeaderR{$header} ne "\n") { + push(@pgp_head, "$$HeaderR{$header}"); + delete $$HeaderR{$header}; + } + } + + push @pgp_head, ("X-PGP-Hash: " . $config{'digest-algo'} . "\n") if (defined($config{'digest-algo'})); + push @pgp_head, ("X-PGP-Key: " . $config{'pgp-signer'} . "\n"), $tmppgpheader; + undef $tmppgpheader; + + @pgp_body = split(/$/m, $pgpbody); + my @pgpmessage = (@pgp_head, "\n", @pgp_body); + return \@pgpmessage; +} + +#-------- sub buildcancelkey +# buildcancelkey builds the cancel-key based on the configured HASH algorithm. +# +# Receives: +# - $data: The input data. +# - $key: The secret key to be used. +# +# Returns: +# - $cancel_key: The calculated cancel-key. +sub buildcancelkey { + my ($data, $key) = @_; + my $cancel_key; + if ($config{'canlock-algorithm'} eq 'sha1') { + $cancel_key = MIME::Base64::encode(Digest::HMAC_SHA1::hmac_sha1($data, $key), ''); + } elsif ($config{'canlock-algorithm'} eq 'sha256') { + $cancel_key = MIME::Base64::encode(Digest::SHA::hmac_sha256($data, $key), ''); + } else { + $cancel_key = MIME::Base64::encode(Digest::SHA::hmac_sha512($data, $key), ''); + } + return $cancel_key; +} + +#-------- sub buildcancellock +# buildcancellock builds the cancel-lock based on the configured HASH algorithm +# and the given cancel-key. +# +# Receives: +# - $sha_mod: A hint which module to be used for sha1. +# - $cancel_key: The cancel-key for which the lock has to be calculated. +# +# Returns: +# - $cancel_lock: The calculated cancel-lock. +sub buildcancellock { + my ($cancel_key, $sha_module) = @_; + my $cancel_lock; + if ($config{'canlock-algorithm'} eq 'sha1') { + if ($sha_module =~ m/SHA1/) { + $cancel_lock = MIME::Base64::encode(Digest::SHA1::sha1($cancel_key, ''), ''); + } else { + $cancel_lock = MIME::Base64::encode(Digest::SHA::sha1($cancel_key, ''), ''); + } + } elsif ($config{'canlock-algorithm'} eq 'sha256') { + $cancel_lock = MIME::Base64::encode(Digest::SHA::sha256($cancel_key, ''), ''); + } else { + $cancel_lock = MIME::Base64::encode(Digest::SHA::sha512($cancel_key, ''), ''); + } + return $cancel_lock; +} + +sub version { + print "".$pname." ".$version."\n"; + return; +} + +sub usage { + version(); + print "Usage: ".$pname." [OPTS] < article\n"; + print " -4 force connecting via IPv4\n"; + print " -a string set Approved:-header to string\n"; + print " -c string set Control:-header to string\n"; + print " -d string set Distribution:-header to string\n"; + print " -e string set Expires:-header to string\n"; + print " -f string set From:-header to string\n"; + print " -i string list of headers to be ignored for signing\n"; + print " -m string set Message-ID:-header to string\n"; + print " -n string set Newsgroups:-header to string\n"; + print " -o string set Organization:-header to string\n"; + print " -p port use port as NNTP port [default=".$config{'nntp-port'}."]\n"; + print " -r string set Reply-To:-header to string\n"; + print " -s string save signed article to directory string instead of posting\n"; + print " -t string set Subject:-header to string\n"; + print " -v show warnings about missing/disabled features\n"; + print " -w string set Followup-To:-header to string\n"; + print " -x string prepend Path:-header with string\n"; + print " -D enable debugging\n"; + print " -E silently discard empty article\n"; + print " -F string set References:-header to string\n"; + print " -H show help\n"; + print " -I do not add Injection-Date: header\n"; + print " -L do not add Cancel-Lock: / Cancel-Key: headers\n"; + print " -O do not add Organization:-header\n"; + print " -R disallow control messages\n"; + print " -S do not append " . $config{'sig-path'} . "\n"; + print " -T seconds set connection timeout to seconds\n"; + print " -X do not sign article\n"; + print " -Y force authentication on connect\n"; + print " --canlock-algorithm string\n"; + print " digest algorithm for Cancel-Lock (sha1, sha256 or sha512)\n"; + print " --ssl use NNTPS (via port 563) if available\n"; + print " --transform convert to \n"; + print " --version show version\n"; + printf("\nAvailable tinewsrc-vars: %s\n", join(", ", sort keys %config)) if ($config{'verbose'} || $config{'debug'}); + exit 0; +} + +__END__ + +=head1 NAME + +tinews.pl - Post and sign an article via NNTP + +=head1 SYNOPSIS + +B [B] E I + +=head1 DESCRIPTION + +B reads an article on STDIN, signs it via L or +L and posts it to a news server. + +The article shall not contain any raw 8-bit data or it needs to +already have the relevant MIME-headers as B will not +add any MIME-headers nor encode its input. + +If the article contains To:, Cc: or Bcc: headers and mail-actions are +configured it will automatically add a "Posted-And-Mailed: yes" header +to the article and send out the mail-copies. + +If a Cancel-Lock secret file is defined it will automatically add a +Cancel-Lock: (and Cancel-Key: if required) header. + +The input should have unix line endings (, '\n'). Use --B +to convert from to just . + +=head1 OPTIONS +X + +=over 4 + +=item -B<4> | --B +X<-4> X<--iv4> + +Force connecting via IPv4 to the remote NNTP server. + +=item -B C | --B C +X<-a> X<--approved> + +Set the article header field Approved: to the given value. + +=item -B C | --B C +X<-c> X<--control> + +Set the article header field Control: to the given value. + +=item -B C | --B C +X<-d> X<--distribution> + +Set the article header field Distribution: to the given value. + +=item -B C | --B C +X<-e> X<--expires> + +Set the article header field Expires: to the given value. + +=item -B C | --B C +X<-f> X<--from> + +Set the article header field From: to the given value. + +=item -B F
| --B F
+X<-i> X<--ignore-headers> + +Comma separated list of headers that will be ignored during signing. +Usually the following headers will be signed if present: + +From, Newsgroups, Subject, Control, Supersedes, Followup-To, +Date, Injection-Date, Sender, Approved, Message-ID, Reply-To, +Cancel-Key, Also-Control and Distribution. + +Some of them may be altered on the Server (i.e. Cancel-Key) which would +invalid the signature, this option can be used the exclude such headers +if required. + +=item -B C | --B C +X<-m> X<--message-id> + +Set the article header field Message-ID: to the given value. + +=item -B C | --B C +X<-n> X<--newsgroups> + +Set the article header field Newsgroups: to the given value. + +=item -B C | --B C +X<-o> X<--organization> + +Set the article header field Organization: to the given value. + +=item -B

C | --B C +X<-p> X<--port> + +use C as NNTP-port + +=item -B C | --B C +X<-r> X<--reply-to> + +Set the article header field Reply-To: to the given value. + +=item -B F | --B F +X<-s> X<--savedir> + +Save signed article to directory F instead of posting. + +=item -B C | --B C +X<-t> X<--subject> + +Set the article header field Subject: to the given value. + +=item -B | --B +X<-v> X<--verbose> + +Warn about disabled options due to lacking perl-modules or executables and +unreadable files and enable warnings about raw 8-bit data. + +=item -B C | --B C +X<-w> X<--followup-to> + +Set the article header field Followup-To: to the given value. + +=item -B C | --B C +X<-x> X<--path> + +Prepend the article header field Path: with the given value. + +=item -B | -B | --B +X<-D> X<-N> X<--debug> + +Set L to debug mode, enable warnings about raw 8-bit data, +warn about disabled options due to lacking perl-modules or executables and +unreadable files. + +=item -B | --B +X<-E> X<--discard-empty> + +Silently discard an empty article. + +=item -B | --B +X<-F> X<--references> + +Set the article header field References: to the given value. + +=item -B | --B +X<-H> X<--help> + +Show help-page. + +=item -B | --B +X<-I> X<--no-injection-date> + +Do not add Injection-Date: header. + +=item -B | --B +X<-L> X<--no-canlock> + +Do not add Cancel-Lock: / Cancel-Key: headers. + +=item -B | --B +X<-O> X<--no-organization> + +Do not add Organization: header. + +=item -B | --B +X<-R> X<--no-control> + +Restricted mode, disallow control-messages. + +=item -B | --B +X<-s> X<--no-signature> + +Do not append F<$HOME/.signature>. + +=item -B C | --B C +X<-T> X<--timeout> + +Override the connection timeout setting. Default is 120 seconds. + +=item -B | --B +X<-X> X<--no-sign> + +Do not sign the article. + +=item -B | --B +X<-Y> X<--force-auth> + +Force authentication on connect even if not required by the server. + +=item --B C +X<--canlock-algorithm> + +Digest algorithm used for Cancel-Lock: / Cancel-Key: headers. +Supported algorithms are sha1, sha256 and sha512. Default is sha1. + +=item --B | --B +X<--ssl> X<--nntps> + +Use NNTPS (via port 563) if available. This requires a recent version +of L and L. Be aware that no SSL +verification will be done. + +=item --B +X<--transform> + +Convert network line endings () to unix line endings (). + +=item --B +X<--version> + +Show version. + +=item -B -B -B +X<-A> X<-V> X<-W> + +These options are accepted for compatibility reasons but ignored. + +=item -B | --B +X<-h> X<--headers> + +These options are accepted for compatibility reasons but ignored. + +=back + +=head1 EXIT STATUS + +The following exit values are returned: + +=over 4 + +=item S< 0> + +Successful completion. + +=item S + +An error occurred. + +=back + +=head1 ENVIRONMENT +X + +=over 4 + +=item B<$NEWSHOST> +X<$NEWSHOST> X + +Set to override the NNTP server configured in the source or config-file. +It has lower priority than B<$NNTPSERVER> and should be avoided. + +=item B<$NNTPSERVER> +X<$NNTPSERVER> X + +Set to override the NNTP server configured in the source or config-file. +This has higher priority than B<$NEWSHOST>. + +=item B<$NNTPPORT> +X<$NNTPPORT> X + +The NNTP TCP-port to post news to. This variable only needs to be set if the +TCP-port is not 119 (the default). The '-B

' command-line option overrides +B<$NNTPPORT>. + +=item B<$PGPPASS> +X<$PGPPASS> X + +Set to override the passphrase configured in the source (used for +L-2.6.3). + +=item B<$PGPPASSFILE> +X<$PGPPASSFILE> X + +Passphrase file used for L or L. + +=item B<$SIGNER> +X<$SIGNER> X + +Set to override the user-id for signing configured in the source. If you +neither set B<$SIGNER> nor configure it in the source the contents of the +From:-field will be used. + +=item B<$REPLYTO> +X<$REPLYTO> X + +Set the article header field Reply-To: to the return address specified by +the variable if there isn't already a Reply-To: header in the article. +The '-B' command-line option overrides B<$REPLYTO>. + +=item B<$ORGANIZATION> +X<$ORGANIZATION> X + +Set the article header field Organization: to the contents of the variable +if there isn't already an Organization: header in the article. The '-B' +command-line option overrides B<$ORGANIZATION>, The '-B' command-line +option disables it. + +=item B<$DISTRIBUTION> +X<$DISTRIBUTION> X + +Set the article header field Distribution: to the contents of the variable +if there isn't already a Distribution: header in the article. The '-B' +command-line option overrides B<$DISTRIBUTION>. + +=back + +=head1 FILES + +=over 4 + +=item F + +Temporary file used to store the reformatted article. + +=item F + +Temporary file used to store the reformatted and signed article. + +=item F<$PGPPASSFILE> + +The passphrase file to be used for L or L. + +=item F<$HOME/.signature> + +Signature file which will be automatically included. + +=item F<$HOME/.cancelsecret> + +The passphrase file to be used for Cancel-Locks. This feature is turned +off by default. + +=item F<$HOME/.newsauth> + +"nntpserver password [user]" pairs or triples for NNTP servers that require +authorization. First match counts. Any line that starts with "#" is a +comment. Blank lines are ignored. This file should be readable only for the +user as it contains the user's unencrypted password for reading news. If no +matching entry is found F<$HOME/.nntpauth> is checked. + +=item F<$HOME/.nntpauth> + +"nntpserver user password" triples for NNTP servers that require +authorization. First match counts. Lines starting with "#" are skipped and +blank lines are ignored. This file should be readable only for the user as +it contains the user's unencrypted password for reading news. +F<$HOME/.newsauth> is checked first. + +=item F<$XDG_CONFIG_HOME/tinewsrc> F<$HOME/.config/tinewsrc> F<$HOME/.tinewsrc> + +"option=value" configuration pairs, last match counts and only +"value" is case sensitive. Lines that start with "#" are ignored. If the +file contains unencrypted passwords (e.g. nntp-pass or pgp-pass), it +should be readable for the user only. Use -B to get a full list of +all available configuration options. + +=back + +=head1 SECURITY + +If you've configured or entered a password, even if the variable that +contained that password has been erased, it may be possible for someone to +find that password, in plaintext, in a core dump. In short, if serious +security is an issue, don't use this script. + +Be aware that even if NNTPS is used still no SSL verification will be done. + +=head1 NOTES + +B is designed to be used with L-2.6.3, +L-5, L-6, L and L. + +B requires the following standard modules to be installed: +L, L, L and +L. + +NNTPS (NNTP with implicit TLS; RFC 4642 and RFC 8143) may be unavailable +if L is too old or L is missing on +the system. B will fallback to unencrypted NNTP in that case. + +If the Cancel-Lock feature (RFC 8315) is enabled the following additional +modules must be installed: L, L or +L and L. sha256 and sha512 as +algorithms for B are only available with L. + +L users may need to set B<$GPG_TTY>, i.e. + + GPG_TTY=$(tty) + export GPG_TTY + +before using B. See L for details. + +B does not do any MIME encoding, its input should be already +properly encoded and have all relevant headers set. + +=head1 AUTHOR + +Urs Janssen Eurs@tin.orgE, +Marc Brockschmidt Emarc@marcbrockschmidt.deE + +=head1 SEE ALSO + +L, L, L, L, L, +L, L, L, +L, L, L, +L, L + +=cut diff --git a/contrib/yearstats.sh b/contrib/yearstats.sh new file mode 100644 index 0000000..3cc2ab4 --- /dev/null +++ b/contrib/yearstats.sh @@ -0,0 +1,11 @@ +#!/bin/bash +# installation path is /srv/newsstats/, please adjust accordingly +# $1: newsgroup +echo "Stats for $1" +cd /srv/newsstats/ +for year in {2012..2022} +do + echo -n "${year}: " + bin/groupstats.pl -m $year-01:$year-12 -r sums -n $1 +done + diff --git a/doc/ChangeLog b/doc/ChangeLog index 569a3e6..e6da31e 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,28 @@ +NewsStats 0.3.0 (2025-05-18) + * Extract GroupStats (in gatherstats) to subroutine. + * Add ParseHeader() to library. + * Add HostStats to gatherstats. + * Add DBTableHosts structure to install script. + * Add cliservstats (for hosts and clients). + - Refactor SQL generators. + * Add --mid option to gatherstats for debugging purposes. + * Don't parse NNTP-Posting-Host to determine the server name. + * Add more known hosts. + * Implement hierarchy check on gatherstats. + * Add sums per month to HostStats. + * Add postingstats and refactor it: + - Make all text configurable (i18n). + - Generalize to make it usable for HostStats. + - Fallback to last month if no month is given. + - Add option handling, import VERSION, add POD. + * Update README, INSTALL and ChangeLog. + * Don't enforce --nocomment for --filetemplate, just default to it. + Change caption handling, update documentation accordingly. + * Fix call to GetMaxLength() in cliservstats. + * Fix typos in documentation, update sample config file. + * Move database creation from install/install.pl to bin/dbcreate.pl + * Add tinews.pl and some shell scripts to /contrib. + NewsStats 0.2.0 (2025-05-10) * Redo directory structure: - Move all scripts to /bin diff --git a/doc/INSTALL b/doc/INSTALL index 24eeaf8..2ef057e 100644 --- a/doc/INSTALL +++ b/doc/INSTALL @@ -1,4 +1,4 @@ -NewsStats (c) 2010-2013 Thomas Hochstein +NewsStats (c) 2010-2013, 2025 Thomas Hochstein NewsStats is a software package used to gather statistical information from a live Usenet feed and for its subsequent examination. @@ -14,7 +14,7 @@ INSTALLATION INSTRUCTIONS 1) Install the scripts * Download the current version of NewsStats from - . + . * Untar it into a directory of your choice: @@ -57,6 +57,9 @@ INSTALLATION INSTRUCTIONS * DBTableGrps = groups_de Table holding data on postings per group. + * DBTableHosts = hosts_de + Table holding data on postings per server. + b) Optional configuration options * TLH = de @@ -67,9 +70,9 @@ INSTALLATION INSTRUCTIONS * Setup your database server with a username, password and database matching the NewsStats configuration (see 2 a). - * Start the installation script: + * Start the database creation script: - # install/install.pl + # bin/dbcreate.pl It will setup the necessary database tables and display some information on the next steps. diff --git a/doc/README b/doc/README index 57f8bec..222cdba 100644 --- a/doc/README +++ b/doc/README @@ -1,4 +1,4 @@ -NewsStats (c) 2010-2013 Thomas Hochstein +NewsStats (c) 2010-2013, 2025 Thomas Hochstein NewsStats is a software package for gathering statistical data live from a Usenet feed and subsequent examination. @@ -13,7 +13,7 @@ What's that? There's a multitude of tools for the statistical examination of newsgroups: number of postings per month or per person, longest - threads, and so on (see + threads, and so on (see [German language] for an incomplete list). Most of them use a per- newsgroup approach while NewsStats is hierarchy oriented. @@ -43,7 +43,7 @@ Prerequisites - File::Basename - Sys::Syslog - * Perl modules form CPAN + * Perl modules from CPAN - Config::Auto - Date::Format - DBI @@ -54,21 +54,28 @@ Prerequisites Installation instructions - See INSTALL. + See INSTALL. + + Documentation is in /doc, configuration in /etc, the NewsStats + module in /lib and most scripts in /bin, while /contrib has some + sample scripts that may have to be adjusted to work in your + configuration. Getting Started 'feedlog.pl' will continuously feed raw data to your raw data table. See the feedlog.pl man page for more information. - You can process that data via 'gatherstats.pl'; currently only the - tabulation of postings per group and month is supported. More to - come. See the gatherstats.pl man page for more information. + You can process that data via 'gatherstats.pl'; currently the + tabulation of postings per group and injection server per month is + supported. Tabulation of clients (newsreaders) is planned. See + the gatherstats.pl man page for more information. Report generation is handled by specialised scripts for each - report type. Currently only reports on the number of postings per - group and month are supported; you can use 'groupstats.pl' for - this. See the groupstats.pl man page for more information. + report type. Currently reports on the number of postings per group + and month and injection server and month are supported; you can + use 'groupstats.pl' and 'cliservstats.pl' for that. See the + groupstats.pl and cliservstats.pl man pages for more information. Reporting Bugs @@ -93,4 +100,3 @@ Author Thomas Hochstein - diff --git a/doc/TODO b/doc/TODO index 63bcfdf..a376c53 100644 --- a/doc/TODO +++ b/doc/TODO @@ -28,8 +28,7 @@ NewsStats. mentioned information; and you should be able to get the history of any group. - Add other reports - NewsStats should include some other kinds of reports (stats on used clients, - on postings hosts/servers, ...) + NewsStats should include some other kinds of reports (stats on used clients) - Add tools for database management NewsStats should offer tools e.g. to inject postings into the 'raw' database, or to split databases. @@ -65,7 +64,7 @@ NewsStats. + gatherstats.pl - Use hierarchy information (see GroupInfo above) - - Add gathering of other stats (clients, hosts, ...) + - Add gathering of other stats (clients, ...) - better modularisation (code reuse for other reports!) - Add / enhance / test error handling - General tests and optimisations diff --git a/etc/newsstats.conf.sample b/etc/newsstats.conf.sample index 3133ed2..a960644 100644 --- a/etc/newsstats.conf.sample +++ b/etc/newsstats.conf.sample @@ -12,8 +12,8 @@ DBDatabase = newsstats # DBTableRaw = raw_de DBTableGrps = groups_de +DBTableHosts = hosts_de #DBTableClnts = -#DBTableHosts = ### hierarchy configuration TLH = de diff --git a/lib/NewsStats.pm b/lib/NewsStats.pm index 11f25f8..d16965b 100644 --- a/lib/NewsStats.pm +++ b/lib/NewsStats.pm @@ -2,7 +2,7 @@ # # Library functions for the NewsStats package. # -# Copyright (c) 2010-2013 Thomas Hochstein +# Copyright (c) 2010-2013, 2025 Thomas Hochstein # # This module can be redistributed and/or modified under the same terms under # which Perl itself is published. @@ -34,6 +34,7 @@ require Exporter; ListNewsgroups ParseHierarchies ReadGroupList + ParseHeaders OutputData FormatOutput SQLHierarchies @@ -48,7 +49,7 @@ require Exporter; Output => [qw(OutputData FormatOutput)], SQLHelper => [qw(SQLHierarchies SQLSortOrder SQLGroupList SQLSetBounds SQLBuildClause GetMaxLength)]); -$VERSION = '0.2.0'; +$VERSION = '0.3.0'; use Data::Dumper; use File::Basename; @@ -76,7 +77,7 @@ sub ShowVersion { ################################################################################ ### display version and exit print "$0 from NewsStats v$VERSION\n"; - print "Copyright (c) 2010-2013 Thomas Hochstein \n"; + print "Copyright (c) 2010-2013, 2025 Thomas Hochstein \n"; print "This program is free software; you may redistribute it ". "and/or modify it under the same terms as Perl itself.\n"; exit(100); @@ -254,6 +255,42 @@ sub ReadGroupList { return \%ValidGroups; }; +################################################################################ +sub ParseHeaders { +################################################################################ +### return a hash of all headers (ignoring duplicate headers) +### parsed from raw headers +### -> taken and modified from pgpverify +### -> Written April 1996, (David C Lawrence) +### -> Currently maintained by Russ Allbery +### IN : $RawHeaders : raw headers as found in posting +### OUT: %Headers : hash containing header contents, +### keyed by lower-case header name + my (%Header, $Label, $Value); + foreach (@_) { + s/\r?\n$//; + + last if /^$/; + + if (/^(\S+):[ \t](.+)/) { + ($Label, $Value) = ($1, $2); + # discard all duplicate headers + next if $Header{lc($Label)}; + $Header{lc($Label)} = $Value; + } elsif (/^\s/) { + # continuation lines + if ($Label) { + $Header{lc($Label)} .= "\n$_"; + } else { + warn (sprintf("Non-header line: %s\n",$_)); + } + } else { + warn (sprintf("Non-header line: %s\n",$_)); + } + } + return %Header; +}; + ################################################################################ #####----------------------------- TimePeriods ----------------------------##### @@ -393,12 +430,13 @@ sub OutputData { ### $GroupBy : primary sorting order (month or key) ### $Precision: number of digits right of decimal point (0 or 2) ### $ValidKeys: reference to a hash containing all valid keys +### $LeadIn : print at start of output ### $FileTempl: file name template (--filetemplate): filetempl-YYYY-MM ### $DBQuery : database query handle with executed query, ### containing $Month, $Key, $Value ### $PadField : padding length for key field (optional) for 'pretty' ### $PadValue : padding length for value field (optional) for 'pretty' - my ($Format, $Comments, $GroupBy, $Precision, $ValidKeys, $FileTempl, + my ($Format, $Comments, $GroupBy, $Precision, $ValidKeys, $LeadIn, $FileTempl, $DBQuery, $PadField, $PadValue) = @_; my %ValidKeys = %{$ValidKeys} if $ValidKeys; my ($FileName, $Handle, $OUT); @@ -441,8 +479,8 @@ sub OutputData { $FileName)); $Handle = $OUT; }; - print $Handle &FormatOutput($Format, $Comments, $Caption, $Key, $Value, - $Precision, $PadField, $PadValue); + print $Handle &FormatOutput($Format, $Comments, $LeadIn, $Caption, + $Key, $Value, $Precision, $PadField, $PadValue); $LastIteration = $Caption; }; close $OUT if ($FileTempl); @@ -461,7 +499,7 @@ sub FormatOutput { ### $PadField : padding length for key field (optional) for 'pretty' ### $PadValue : padding length for value field (optional) for 'pretty' ### OUT: $Output: formatted output - my ($Format, $Comments, $Caption, $Key, $Value, $Precision, $PadField, + my ($Format, $Comments, $LeadIn, $Caption, $Key, $Value, $Precision, $PadField, $PadValue) = @_; my ($Output); # keep last caption in mind @@ -477,8 +515,10 @@ sub FormatOutput { $Output = sprintf ("%s %s %u\n",$Caption,$Key,$Value); } elsif ($Format eq 'pretty') { # output as a table - $Output = sprintf ("# ----- %s:\n",$Caption) - if ($Comments and (!defined($LastIteration) or $Caption ne $LastIteration)); + if ($Comments and (!defined($LastIteration) or $Caption ne $LastIteration)) { + $Output = $LeadIn; + $Output .= sprintf ("# ----- %s:\n",$Caption); + } # increase $PadValue for numbers with decimal point $PadValue += $Precision+1 if $Precision; # add padding if $PadField is set; $PadValue HAS to be set then @@ -542,21 +582,22 @@ sub SQLSortOrder { ### IN : $GroupBy: primary sort by 'month' (default) or 'newsgroups' ### $OrderBy: secondary sort by month/newsgroups (default) ### or number of 'postings' +### $Type : newsgroup, host, client ### OUT: a SQL ORDER BY clause - my ($GroupBy,$OrderBy) = @_; + my ($GroupBy,$OrderBy,$Type) = @_; my ($GroupSort,$OrderSort) = ('',''); # $GroupBy (primary sorting) if (!$GroupBy) { $GroupBy = 'month'; } else { ($GroupBy, $GroupSort) = SQLParseOrder($GroupBy); - if ($GroupBy =~ /group/i) { - $GroupBy = 'newsgroup'; + if ($GroupBy =~ /name/i) { + $GroupBy = $Type; } else { $GroupBy = 'month'; } } - my $Secondary = ($GroupBy eq 'month') ? 'newsgroup' : 'month'; + my $Secondary = ($GroupBy eq 'month') ? $Type : 'month'; # $OrderBy (secondary sorting) if (!$OrderBy) { $OrderBy = $Secondary; @@ -592,44 +633,45 @@ sub SQLParseOrder { ################################################################################ sub SQLGroupList { ################################################################################ -### explode list of newsgroups separated by : (with wildcards) +### explode list of names separated by : (with wildcards) ### to a SQL 'WHERE' expression -### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*) +### IN : $Names: list of names, e.g. newsgroups (group.one.*:group.two:group.three.*) +### $Type : newsgroup, host, client ### OUT: SQL code to become part of a 'WHERE' clause, -### list of newsgroups for SQL bindings - my ($Newsgroups) = @_; +### list of names for SQL bindings + my ($Names,$Type) = @_; # substitute '*' wildcard with SQL wildcard character '%' - $Newsgroups =~ s/\*/%/g; - return (undef,undef) if !CheckValidNewsgroups($Newsgroups); - # just one newsgroup? - return (SQLGroupWildcard($Newsgroups),$Newsgroups) if $Newsgroups !~ /:/; - my ($SQL,@WildcardGroups,@NoWildcardGroups); - # list of newsgroups separated by ':' - my @GroupList = split /:/, $Newsgroups; - foreach (@GroupList) { + $Names =~ s/\*/%/g; + return (undef,undef) if !CheckValidNames($Names); + # just one name/newsgroup? + return (SQLGroupWildcard($Names,$Type),$Names) if $Names !~ /:/; + my ($SQL,@WildcardNames,@NoWildcardNames); + # list of names/newsgroups separated by ':' + my @NameList = split /:/, $Names; + foreach (@NameList) { if ($_ !~ /%/) { - # add to list of newsgroup names WITHOUT wildcard - push (@NoWildcardGroups,$_); + # add to list of names/newsgroup names WITHOUT wildcard + push (@NoWildcardNames,$_); } else { - # add to list of newsgroup names WITH wildcard - push (@WildcardGroups,$_); + # add to list of names WITH wildcard + push (@WildcardNames,$_); # add wildcard to SQL clause # 'OR' if SQL clause is not empty $SQL .= ' OR ' if $SQL; - $SQL .= 'newsgroup LIKE ?' + $SQL .= "$Type LIKE ?" } }; - if (scalar(@NoWildcardGroups)) { + if (scalar(@NoWildcardNames)) { # add 'OR' if SQL clause is not empty $SQL .= ' OR ' if $SQL; - if (scalar(@NoWildcardGroups) < 2) { - # special case: just one newsgroup without wildcard - $SQL .= 'newsgroup = ?'; + if (scalar(@NoWildcardNames) < 2) { + # special case: just one name without wildcard + $SQL .= "$Type = ?"; } else { - # create list of newsgroups to include: 'newsgroup IN (...)' - $SQL .= 'newsgroup IN ('; + # create list of names to include: e.g. 'newsgroup IN (...)' + $SQL .= "$Type IN ("; my $SQLin; - foreach (@NoWildcardGroups) { + foreach (@NoWildcardNames) { $SQLin .= ',' if $SQLin; $SQLin .= '?'; } @@ -637,27 +679,28 @@ sub SQLGroupList { $SQL .= $SQLin .= ')'; } } - # add brackets '()' to SQL clause as needed (more than one wildcard group) - if (scalar(@WildcardGroups)) { + # add brackets '()' to SQL clause as needed (more than one wildcard name) + if (scalar(@WildcardNames)) { $SQL = '(' . $SQL .')'; } - # rebuild @GroupList in (now) correct order - @GroupList = (@WildcardGroups,@NoWildcardGroups); - return ($SQL,@GroupList); + # rebuild @NameList in (now) correct order + @NameList = (@WildcardNames,@NoWildcardNames); + return ($SQL,@NameList); }; ################################################################################ sub SQLGroupWildcard { ################################################################################ ### build a valid SQL 'WHERE' expression with or without wildcards -### IN : $Newsgroup: newsgroup expression, probably with wildcard -### (group.name or group.name.%) +### IN : $Name: expression, probably with wildcard +### (group.name or group.name.%) +### $Type: newsgroup, host, client ### OUT: SQL code to become part of a 'WHERE' clause - my ($Newsgroup) = @_; - if ($Newsgroup !~ /%/) { - return 'newsgroup = ?'; + my ($Name,$Type) = @_; + if ($Name !~ /%/) { + return "$Type = ?"; } else { - return 'newsgroup LIKE ?'; + return "$Type LIKE ?"; } }; @@ -759,14 +802,14 @@ sub SQLBuildClause { #####--------------------------- Verifications ----------------------------##### ################################################################################ -sub CheckValidNewsgroups { +sub CheckValidNames { ################################################################################ -### syntax check of newgroup list -### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*) +### syntax check of a list +### IN : $Names: list of names, e.g. newsgroups (group.one.*:group.two:group.three.*) ### OUT: boolean - my ($Newsgroups) = @_; + my ($Names) = @_; my $InvalidCharRegExp = ',; '; - return ($Newsgroups =~ /[$InvalidCharRegExp]/) ? 0 : 1; + return ($Names =~ /[$InvalidCharRegExp]/) ? 0 : 1; };