diff --git a/bin/cliservstats.pl b/bin/cliservstats.pl deleted file mode 100644 index a38cba0..0000000 --- a/bin/cliservstats.pl +++ /dev/null @@ -1,537 +0,0 @@ -#! /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/bin/gatherstats.pl b/bin/gatherstats.pl index 15b7ad4..60043d1 100755 --- a/bin/gatherstats.pl +++ b/bin/gatherstats.pl @@ -7,7 +7,7 @@ # # It is part of the NewsStats package. # -# Copyright (c) 2010-2013, 2025 Thomas Hochstein +# Copyright (c) 2010-2013 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 ParseHeaders); +use NewsStats qw(:DEFAULT :TimePeriods ListNewsgroups ParseHierarchies ReadGroupList); use DBI; use Getopt::Long qw(GetOptions); @@ -31,21 +31,19 @@ Getopt::Long::config ('bundling'); # define types of information that can be gathered # all / groups (/ clients / hosts) my %LegalStats; -@LegalStats{('all','groups','hosts')} = (); +@LegalStats{('all','groups')} = (); ################################# Main program ################################# ### read commandline options my ($OptCheckgroupsFile,$OptClientsDB,$OptDebug,$OptGroupsDB,$OptTLH, - $OptHostsDB,$OptMID,$OptMonth,$OptRawDB,$OptStatsType,$OptTest, - $OptConfFile); + $OptHostsDB,$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, @@ -66,11 +64,6 @@ $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)) @@ -115,9 +108,6 @@ 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; @@ -125,262 +115,90 @@ foreach my $Month (&ListMonth($Period)) { print "---------- $Month ----------\n" if $OptDebug; - ### GroupStats if ($OptStatsType eq 'all' or $OptStatsType eq 'groups') { - &GroupStats($DBHandle,$DBRaw,$DBGrps,$Month,$TLH,$OptCheckgroupsFile,$OptMID,$OptTest,$OptDebug); - }; + # read list of newsgroups from --checkgroups + # into a hash + my %ValidGroups = %{ReadGroupList(sprintf('%s-%s',$OptCheckgroupsFile,$Month))} + if $OptCheckgroupsFile; - ### 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); + ### ---------------------------------------------- + ### 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 }; }; ### 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 ################################# @@ -413,7 +231,9 @@ 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. +information to process. Currently that doesn't matter yet as only +processing of the number of postings per group per month is +implemented anyway. Possible information types include: @@ -435,15 +255,6 @@ 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 @@ -488,8 +299,9 @@ by a colon). =item B<-s>, B<--stats> I -Set processing type to one of I, I or I. Defaults -to all. +Set processing type to one of I and I. Defaults to all +(and is currently rather pointless as only I has been +implemented). =item B<-c>, B<--checkgroups> I @@ -605,7 +417,7 @@ Thomas Hochstein =head1 COPYRIGHT AND LICENSE -Copyright (c) 2010-2013, 2025 Thomas Hochstein +Copyright (c) 2010-2013 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 cc13550..b716566 100755 --- a/bin/groupstats.pl +++ b/bin/groupstats.pl @@ -51,8 +51,10 @@ GetOptions ('b|boundary=s' => \$OptBoundType, '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)); +# $OptComments defaults to TRUE +$OptComments = 1 if (!defined($OptComments)); +# force --nocomments when --filetemplate is used +$OptComments = 0 if ($OptFileTemplate); # parse $OptBoundType if ($OptBoundType) { if ($OptBoundType =~ /level/i) { @@ -108,7 +110,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,'newsgroup'); + ($SQLWhereNewsgroups,@SQLBindNewsgroups) = &SQLGroupList($OptNewsgroups); # bail out if --newsgroups is invalid &Bleat(2,"--newsgroups option has an invalid format!") if !$SQLWhereNewsgroups; @@ -141,7 +143,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, 'newsgroup'); +my ($GroupBy,$SQLOrderClause) = SQLSortOrder($OptGroupBy, $OptOrderBy); # $GroupBy will contain 'month' or 'newsgroup' (parsed result of $OptGroupBy) # set it to 'month' or 'key' for OutputData() $GroupBy = ($GroupBy eq 'month') ? 'month' : 'key'; @@ -224,7 +226,6 @@ $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)'; @@ -234,9 +235,9 @@ if ($OptCaptions && $OptComments) { $CaptionReportType= '(number of all postings for that time period)' if $OptReportType eq 'sum'; } - $LeadIn .= sprintf("# ----- Report for %s %s\n",$CaptionPeriod,$CaptionReportType); + printf("# ----- Report for %s %s\n",$CaptionPeriod,$CaptionReportType); # print newsgroup list if --newsgroups is set - $LeadIn .= sprintf("# ----- Newsgroups: %s\n",join(',',split(/:/,$OptNewsgroups))) + printf("# ----- Newsgroups: %s\n",join(',',split(/:/,$OptNewsgroups))) if $OptNewsgroups; # print boundaries, if set my $CaptionBoundary= '(counting only month fulfilling this condition)'; @@ -245,12 +246,12 @@ if ($OptCaptions && $OptComments) { $CaptionBoundary= '(on average)' if $OptBoundType eq 'average'; $CaptionBoundary= '(all month summed up)' if $OptBoundType eq 'sum'; } - $LeadIn .= sprintf("# ----- Threshold: %s %s x %s %s %s\n", + printf("# ----- 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", + printf("# ----- 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 ' : '', @@ -259,7 +260,7 @@ if ($OptCaptions && $OptComments) { # output data &OutputData($OptFormat,$OptComments,$GroupBy,$Precision, - $OptCheckgroupsFile ? $ValidGroups : '',$LeadIn, + $OptCheckgroupsFile ? $ValidGroups : '', $OptFileTemplate,$DBQuery,$MaxLength,$MaxValLength); ### close handles @@ -335,6 +336,7 @@ 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 @@ -587,11 +589,10 @@ 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. +Add comments (group headers) to I and I output. True by default. Use I<--nocomments> to suppress anything except newsgroup names/months and -numbers of postings. +numbers of postings. This is enforced when using B<--filetemplate>, see below. =item B<--filetemplate> I @@ -605,6 +606,8 @@ 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 deleted file mode 100644 index e6fe3db..0000000 --- a/bin/postingstats.pl +++ /dev/null @@ -1,354 +0,0 @@ -#!/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 deleted file mode 100644 index 30ef8f1..0000000 --- a/contrib/dopostingstats.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/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 deleted file mode 100644 index b90199e..0000000 --- a/contrib/tinews.pl +++ /dev/null @@ -1,1506 +0,0 @@ -#! /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 deleted file mode 100644 index 3cc2ab4..0000000 --- a/contrib/yearstats.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/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 e6da31e..569a3e6 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,28 +1,3 @@ -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 2ef057e..24eeaf8 100644 --- a/doc/INSTALL +++ b/doc/INSTALL @@ -1,4 +1,4 @@ -NewsStats (c) 2010-2013, 2025 Thomas Hochstein +NewsStats (c) 2010-2013 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,9 +57,6 @@ 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 @@ -70,9 +67,9 @@ INSTALLATION INSTRUCTIONS * Setup your database server with a username, password and database matching the NewsStats configuration (see 2 a). - * Start the database creation script: + * Start the installation script: - # bin/dbcreate.pl + # install/install.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 222cdba..57f8bec 100644 --- a/doc/README +++ b/doc/README @@ -1,4 +1,4 @@ -NewsStats (c) 2010-2013, 2025 Thomas Hochstein +NewsStats (c) 2010-2013 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 from CPAN + * Perl modules form CPAN - Config::Auto - Date::Format - DBI @@ -54,28 +54,21 @@ Prerequisites Installation instructions - 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. + See INSTALL. 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 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. + 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. Report generation is handled by specialised scripts for each - 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. + 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. Reporting Bugs @@ -100,3 +93,4 @@ Author Thomas Hochstein + diff --git a/doc/TODO b/doc/TODO index a376c53..63bcfdf 100644 --- a/doc/TODO +++ b/doc/TODO @@ -28,7 +28,8 @@ 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) + NewsStats should include some other kinds of reports (stats on used clients, + on postings hosts/servers, ...) - Add tools for database management NewsStats should offer tools e.g. to inject postings into the 'raw' database, or to split databases. @@ -64,7 +65,7 @@ NewsStats. + gatherstats.pl - Use hierarchy information (see GroupInfo above) - - Add gathering of other stats (clients, ...) + - Add gathering of other stats (clients, hosts, ...) - 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 a960644..3133ed2 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/bin/dbcreate.pl b/install/install.pl similarity index 84% rename from bin/dbcreate.pl rename to install/install.pl index ea0fd6c..826052d 100755 --- a/bin/dbcreate.pl +++ b/install/install.pl @@ -1,19 +1,19 @@ #! /usr/bin/perl # -# dbcreate.pl +# install.pl # # This script will create database tables as necessary. # # It is part of the NewsStats package. # -# Copyright (c) 2010-2013, 2025 Thomas Hochstein +# Copyright (c) 2010-2013 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 + # we're in .../install, 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 }); @@ -178,7 +162,7 @@ if (!$OptUpdate) { $DBQuery->execute() or &Bleat(2, sprintf("Can't create database %s: %s%\n", $Conf{'DBDatabase'}, $DBI::errstr)); - printf("Database %s created succesfully.\n",$Conf{'DBDatabase'}); + printf("Database table %s created succesfully.\n",$Conf{'DBDatabase'}); $DBHandle->disconnect; }; @@ -201,7 +185,7 @@ if (!$OptUpdate) { } else { ##### upgrade mode print "----------\nStarting upgrade process.\n"; - my $PackageVersion = '0.03'; + $PackageVersion = '0.03'; if ($OptUpdate < $PackageVersion) { if ($OptUpdate < 0.02) { # 0.01 -> 0.02 @@ -231,7 +215,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}); @@ -261,11 +245,11 @@ __END__ =head1 NAME -dbcreate - database creation script +install - installation script =head1 SYNOPSIS -B [B<-Vh> [--update I] [B<--conffile> I] +B [B<-Vh> [--update I] [B<--conffile> I] =head1 REQUIREMENTS @@ -273,12 +257,11 @@ See L. =head1 DESCRIPTION -This script will create a database and database tables as necessary -and configured. +This script will create 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. @@ -310,7 +293,7 @@ Load configuration from I instead of F. =over 4 -=item F +=item F The script itself. @@ -351,7 +334,7 @@ Thomas Hochstein =head1 COPYRIGHT AND LICENSE -Copyright (c) 2010-2013, 2025 Thomas Hochstein +Copyright (c) 2010-2013 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/lib/NewsStats.pm b/lib/NewsStats.pm index d16965b..11f25f8 100644 --- a/lib/NewsStats.pm +++ b/lib/NewsStats.pm @@ -2,7 +2,7 @@ # # Library functions for the NewsStats package. # -# Copyright (c) 2010-2013, 2025 Thomas Hochstein +# Copyright (c) 2010-2013 Thomas Hochstein # # This module can be redistributed and/or modified under the same terms under # which Perl itself is published. @@ -34,7 +34,6 @@ require Exporter; ListNewsgroups ParseHierarchies ReadGroupList - ParseHeaders OutputData FormatOutput SQLHierarchies @@ -49,7 +48,7 @@ require Exporter; Output => [qw(OutputData FormatOutput)], SQLHelper => [qw(SQLHierarchies SQLSortOrder SQLGroupList SQLSetBounds SQLBuildClause GetMaxLength)]); -$VERSION = '0.3.0'; +$VERSION = '0.2.0'; use Data::Dumper; use File::Basename; @@ -77,7 +76,7 @@ sub ShowVersion { ################################################################################ ### display version and exit print "$0 from NewsStats v$VERSION\n"; - print "Copyright (c) 2010-2013, 2025 Thomas Hochstein \n"; + print "Copyright (c) 2010-2013 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); @@ -255,42 +254,6 @@ 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 ----------------------------##### @@ -430,13 +393,12 @@ 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, $LeadIn, $FileTempl, + my ($Format, $Comments, $GroupBy, $Precision, $ValidKeys, $FileTempl, $DBQuery, $PadField, $PadValue) = @_; my %ValidKeys = %{$ValidKeys} if $ValidKeys; my ($FileName, $Handle, $OUT); @@ -479,8 +441,8 @@ sub OutputData { $FileName)); $Handle = $OUT; }; - print $Handle &FormatOutput($Format, $Comments, $LeadIn, $Caption, - $Key, $Value, $Precision, $PadField, $PadValue); + print $Handle &FormatOutput($Format, $Comments, $Caption, $Key, $Value, + $Precision, $PadField, $PadValue); $LastIteration = $Caption; }; close $OUT if ($FileTempl); @@ -499,7 +461,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, $LeadIn, $Caption, $Key, $Value, $Precision, $PadField, + my ($Format, $Comments, $Caption, $Key, $Value, $Precision, $PadField, $PadValue) = @_; my ($Output); # keep last caption in mind @@ -515,10 +477,8 @@ sub FormatOutput { $Output = sprintf ("%s %s %u\n",$Caption,$Key,$Value); } elsif ($Format eq 'pretty') { # output as a table - if ($Comments and (!defined($LastIteration) or $Caption ne $LastIteration)) { - $Output = $LeadIn; - $Output .= sprintf ("# ----- %s:\n",$Caption); - } + $Output = sprintf ("# ----- %s:\n",$Caption) + if ($Comments and (!defined($LastIteration) or $Caption ne $LastIteration)); # increase $PadValue for numbers with decimal point $PadValue += $Precision+1 if $Precision; # add padding if $PadField is set; $PadValue HAS to be set then @@ -582,22 +542,21 @@ 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,$Type) = @_; + my ($GroupBy,$OrderBy) = @_; my ($GroupSort,$OrderSort) = ('',''); # $GroupBy (primary sorting) if (!$GroupBy) { $GroupBy = 'month'; } else { ($GroupBy, $GroupSort) = SQLParseOrder($GroupBy); - if ($GroupBy =~ /name/i) { - $GroupBy = $Type; + if ($GroupBy =~ /group/i) { + $GroupBy = 'newsgroup'; } else { $GroupBy = 'month'; } } - my $Secondary = ($GroupBy eq 'month') ? $Type : 'month'; + my $Secondary = ($GroupBy eq 'month') ? 'newsgroup' : 'month'; # $OrderBy (secondary sorting) if (!$OrderBy) { $OrderBy = $Secondary; @@ -633,45 +592,44 @@ sub SQLParseOrder { ################################################################################ sub SQLGroupList { ################################################################################ -### explode list of names separated by : (with wildcards) +### explode list of newsgroups separated by : (with wildcards) ### to a SQL 'WHERE' expression -### IN : $Names: list of names, e.g. newsgroups (group.one.*:group.two:group.three.*) -### $Type : newsgroup, host, client +### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*) ### OUT: SQL code to become part of a 'WHERE' clause, -### list of names for SQL bindings - my ($Names,$Type) = @_; +### list of newsgroups for SQL bindings + my ($Newsgroups) = @_; # substitute '*' wildcard with SQL wildcard character '%' - $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) { + $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) { if ($_ !~ /%/) { - # add to list of names/newsgroup names WITHOUT wildcard - push (@NoWildcardNames,$_); + # add to list of newsgroup names WITHOUT wildcard + push (@NoWildcardGroups,$_); } else { - # add to list of names WITH wildcard - push (@WildcardNames,$_); + # add to list of newsgroup names WITH wildcard + push (@WildcardGroups,$_); # add wildcard to SQL clause # 'OR' if SQL clause is not empty $SQL .= ' OR ' if $SQL; - $SQL .= "$Type LIKE ?" + $SQL .= 'newsgroup LIKE ?' } }; - if (scalar(@NoWildcardNames)) { + if (scalar(@NoWildcardGroups)) { # add 'OR' if SQL clause is not empty $SQL .= ' OR ' if $SQL; - if (scalar(@NoWildcardNames) < 2) { - # special case: just one name without wildcard - $SQL .= "$Type = ?"; + if (scalar(@NoWildcardGroups) < 2) { + # special case: just one newsgroup without wildcard + $SQL .= 'newsgroup = ?'; } else { - # create list of names to include: e.g. 'newsgroup IN (...)' - $SQL .= "$Type IN ("; + # create list of newsgroups to include: 'newsgroup IN (...)' + $SQL .= 'newsgroup IN ('; my $SQLin; - foreach (@NoWildcardNames) { + foreach (@NoWildcardGroups) { $SQLin .= ',' if $SQLin; $SQLin .= '?'; } @@ -679,28 +637,27 @@ sub SQLGroupList { $SQL .= $SQLin .= ')'; } } - # add brackets '()' to SQL clause as needed (more than one wildcard name) - if (scalar(@WildcardNames)) { + # add brackets '()' to SQL clause as needed (more than one wildcard group) + if (scalar(@WildcardGroups)) { $SQL = '(' . $SQL .')'; } - # rebuild @NameList in (now) correct order - @NameList = (@WildcardNames,@NoWildcardNames); - return ($SQL,@NameList); + # rebuild @GroupList in (now) correct order + @GroupList = (@WildcardGroups,@NoWildcardGroups); + return ($SQL,@GroupList); }; ################################################################################ sub SQLGroupWildcard { ################################################################################ ### build a valid SQL 'WHERE' expression with or without wildcards -### IN : $Name: expression, probably with wildcard -### (group.name or group.name.%) -### $Type: newsgroup, host, client +### IN : $Newsgroup: newsgroup expression, probably with wildcard +### (group.name or group.name.%) ### OUT: SQL code to become part of a 'WHERE' clause - my ($Name,$Type) = @_; - if ($Name !~ /%/) { - return "$Type = ?"; + my ($Newsgroup) = @_; + if ($Newsgroup !~ /%/) { + return 'newsgroup = ?'; } else { - return "$Type LIKE ?"; + return 'newsgroup LIKE ?'; } }; @@ -802,14 +759,14 @@ sub SQLBuildClause { #####--------------------------- Verifications ----------------------------##### ################################################################################ -sub CheckValidNames { +sub CheckValidNewsgroups { ################################################################################ -### syntax check of a list -### IN : $Names: list of names, e.g. newsgroups (group.one.*:group.two:group.three.*) +### syntax check of newgroup list +### IN : $Newsgroups: list of newsgroups (group.one.*:group.two:group.three.*) ### OUT: boolean - my ($Names) = @_; + my ($Newsgroups) = @_; my $InvalidCharRegExp = ',; '; - return ($Names =~ /[$InvalidCharRegExp]/) ? 0 : 1; + return ($Newsgroups =~ /[$InvalidCharRegExp]/) ? 0 : 1; };