5 # This script will parse a database with raw header information
6 # from a INN feed to a structured database.
8 # It is part of the NewsStats package.
10 # Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
12 # It can be redistributed and/or modified under the same terms under
13 # which Perl itself is published.
16 our $VERSION = "0.01";
18 # we're in .../bin, so our module is in ../lib
19 push(@INC, dirname($0).'/../lib');
24 use NewsStats qw(:DEFAULT :TimePeriods :SQLHelper);
27 use Getopt::Long qw(GetOptions);
28 Getopt::Long::config ('bundling');
30 use Encode qw/decode/;
33 ################################# Definitions ##################################
35 # define header names with separate database fields
36 my %DBFields = ('date' => 'date',
37 'references' => 'refs',
38 'followup-to' => 'fupto',
41 'reply-to' => 'replyto',
42 'subject' => 'subject',
43 'organization' => 'organization',
44 'lines' => 'linecount',
45 'approved' => 'approved',
46 'supersedes' => 'supersedes',
47 'expires' => 'expires',
48 'user-agent' => 'useragent',
49 'x-newsreader' => 'xnewsreader',
50 'x-mailer' => 'xmailer',
51 'x-no-archive' => 'xnoarchive',
52 'content-type' => 'contenttype',
53 'content-transfer-encoding' => 'contentencoding',
54 'cancel-lock' => 'cancellock',
55 'injection-info' => 'injectioninfo',
56 'x-trace' => 'xtrace',
57 'nntp-posting-host' => 'postinghost');
59 # define field list for database
60 my @DBFields = qw/day mid refs date path newsgroups fupto from_ from_parsed
61 from_name from_address sender sender_parsed sender_name
62 sender_address replyto replyto_parsed replyto_name
63 replyto_address subject subject_parsed organization linecount
64 approved supersedes expires useragent xnewsreader xmailer
65 xnoarchive contenttype contentencoding cancellock injectioninfo
66 xtrace postinghost headers disregard/;
68 ################################# Main program #################################
70 ### read commandline options
71 my ($OptDay,$OptDebug,$OptParseDB,$OptRawDB,$OptTest,$OptConfFile);
72 GetOptions ('d|day=s' => \$OptDay,
73 'debug!' => \$OptDebug,
74 'parsedb=s' => \$OptParseDB,
75 'rawdb=s' => \$OptRawDB,
76 't|test!' => \$OptTest,
77 'conffile=s' => \$OptConfFile,
78 'h|help' => \&ShowPOD,
79 'V|version' => \&ShowVersion) or exit 1;
81 ### read configuration
82 my %Conf = %{ReadConfig($OptConfFile)};
84 ### override configuration via commandline options
86 $ConfOverride{'DBTableRaw'} = $OptRawDB if $OptRawDB;
87 $ConfOverride{'DBTableParse'} = $OptParseDB if $OptParseDB;
88 &OverrideConfig(\%Conf,\%ConfOverride);
91 ### and set $Period for output and expression for SQL 'WHERE' clause
92 my ($Period,$SQLWherePeriod) = &GetTimePeriod($OptDay,'day');
93 # bail out if --month is invalid or "all"
94 &Bleat(2,"--day option has an invalid format - please use 'YYYY-MM-DD' or ".
95 "'YYYY-MM-DD:YYYY-MM-DD'!") if (!$Period or $Period eq 'all time');
98 my $DBHandle = InitDB(\%Conf,1);
101 &Bleat(1,'Test mode. Database is not updated.') if $OptTest;
103 # create $SQLWhereClause
104 my $SQLWhereClause = SQLBuildClause('where',$SQLWherePeriod,'NOT disregard');
106 # delete old data for current period
108 print "----------- Deleting old data ... -----------\n" if $OptDebug;
109 my $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s.%s %s",
110 $Conf{'DBDatabase'},$Conf{'DBTableParse'},
112 or &Bleat(2,sprintf("Can't delete old parsed data for %s from %s.%s: ".
113 "$DBI::errstr\n",$Period,
114 $Conf{'DBDatabase'},$Conf{'DBTableParse'}));
117 # read from DBTableRaw
118 print "-------------- Reading data ... -------------\n" if $OptDebug;
119 my $DBQuery = $DBHandle->prepare(sprintf("SELECT id, day, mid, peer, path, ".
120 "newsgroups, headers, disregard ".
121 "FROM %s.%s %s", $Conf{'DBDatabase'},
122 $Conf{'DBTableRaw'}, $SQLWhereClause));
124 or &Bleat(2,sprintf("Can't get data for %s from %s.%s: ".
125 "$DBI::errstr\n",$Period,
126 $Conf{'DBDatabase'},$Conf{'DBTableRaw'}));
128 # set output and database connection to UTF-8
129 # as we're going to write decoded header contents containing UTF-8 chars
130 binmode(STDOUT, ":utf8");
131 $DBHandle->do("SET NAMES 'utf8'");
133 # create a list of supported encondings
135 foreach (Encode->encodings()) {
136 $LegalEncodings{$_} = 1;
138 # parse data in a loop and write it out
139 print "-------------- Parsing data ... -------------\n" if $OptDebug;
140 while (my $HeadersR = $DBQuery->fetchrow_hashref) {
141 my %Headers = %{$HeadersR};
143 # parse $Headers{'headers'} ('headers' from DBTableRaw)
144 # remove empty lines (that should not even exist in a header!)
145 $Headers{'headers'} =~ s/\n\s*\n/\n/g;
146 # merge continuation lines
147 # from Perl Cookbook, 1st German ed. 1999, pg. 91
148 $Headers{'headers'} =~ s/\n\s+/ /g;
149 # split headers in single lines
151 for (split(/\n/,$Headers{'headers'})) {
152 # split header lines in header name and header content
155 ($key,$value) = split(/:/,$_,2);
157 $value =~ s/^\s*(.+)\s*$/$1/;
159 &Bleat(1,sprintf("Illegal header line in %s.%s id %s: %s",
160 $Conf{'DBDatabase'}, $Conf{'DBTableRaw'},
164 # check for empty (mandatory) fields from DBTableRaw
165 # and set them from $Headers{'headers', if necessary
166 if (lc($key) =~ /^(message-id|path|newsgroups)$/) {
167 my $HeaderName = lc($key);
168 $HeaderName = 'mid' if ($HeaderName eq 'message-id');
169 if (!defined($Headers{$HeaderName}) or $Headers{$HeaderName} eq '') {
170 $Headers{$HeaderName} = $value;
171 &Bleat(1,sprintf("Taking missing %s from 'headers' in %s.%s id %s.",
172 $HeaderName, $Conf{'DBDatabase'}, $Conf{'DBTableRaw'},
176 # save each header, separate database fields in %Headers,
177 # the rest in $OtherHeaders (but not Message-ID, Path, Peer
178 # and Newsgroups as those do already exist)
179 if (defined($DBFields{lc($key)})) {
180 $Headers{$DBFields{lc($key)}} = $value;
182 $OtherHeaders .= sprintf("%s: %s\n",$key,$value)
183 if lc($key) !~ /^(message-id|path|peer|newsgroups)$/;
186 # replace old (now parsed) $Headers{'headers'} with remanining $OtherHeaders
187 chomp($OtherHeaders);
188 $Headers{'headers'} = $OtherHeaders;
190 foreach ('from_','sender', 'replyto', 'subject') {
193 $HeaderName =~ s/_$//;
194 # decode From: / Sender: / Reply-To: / Subject:
195 if ($Headers{$_} =~ /\?(B|Q)\?/) {
196 # check for legal encoding and decode
197 (my $Encoding) = $Headers{$_} =~ /\?([^?]+)\?(B|Q)\?/;
198 $Headers{$HeaderName.'_parsed'} = decode('MIME-Header',$Headers{$_})
199 if (exists($LegalEncodings{$Encoding}));
201 # forcibly modify headers with un-encoded 8bit data assuming utf-8
202 # TODO: try to guess correct enconding
203 elsif ($Headers{$_} =~ /[^\x00-\x7F]/) {
204 $Headers{$_} = decode('utf-8',$Headers{$_});
206 # extract name(s) and mail(s) from From: / Sender: / Reply-To:
207 # in parsed form, if available
208 if ($_ ne 'subject') {
210 # start parser on header or parsed header
211 # @Address will have an array of Mail::Address objects, one for
212 # each name/mail (you can have more than one person in From:!)
213 if (defined($Headers{$HeaderName.'_parsed'})) {
214 @Address = Mail::Address->parse($Headers{$HeaderName.'_parsed'});
216 @Address = Mail::Address->parse($Headers{$_});
218 # split each Mail::Address object to @Names and @Adresses
219 my (@Names,@Adresses);
221 # take address part in @Addresses
222 push (@Adresses, $_->address());
223 # take name part form "phrase", if there is one:
224 # From: My Name <addr@ess> (Comment)
225 # otherwise, take it from "comment":
226 # From: addr@ess (Comment)
227 # and push it in @Names
229 $Name = $_->comment() unless $Name = $_->phrase;
230 $Name =~ s/^\((.+)\)$/$1/;
231 push (@Names, $Name);
233 # put all @Adresses and all @Names in %Headers as comma separated lists
234 $Headers{$HeaderName.'_address'} = join(', ',@Adresses);
235 $Headers{$HeaderName.'_name'} = join(', ',@Names);
240 # order output for database entry: fill @SQLBindVars
241 print "-------------- Next entry:\n" if $OptDebug;
243 foreach (@DBFields) {
244 if (defined($Headers{$_}) and $Headers{$_} ne '') {
245 push (@SQLBindVars,$Headers{$_});
246 printf ("FOUND: %s -> %s\n",$_,$Headers{$_}) if $OptDebug;
248 push (@SQLBindVars,undef);
252 # write data to DBTableParse
254 print "-------------- Writing data ... -------------\n" if $OptDebug;
256 $DBHandle->prepare(sprintf("INSERT INTO %s.%s (%s) VALUES (%s)",
258 $Conf{'DBTableParse'},
259 # get field names from @DBFields
260 join(', ',@DBFields),
261 # create a list of '?' for each DBField
263 split(/ /,'? ' x scalar(@DBFields)))
265 $DBWrite->execute(@SQLBindVars)
266 or &Bleat(2,sprintf("Can't write parsed data for %s to %s.%s for %s: ".
267 "$DBI::errstr\n",$Period,
268 $Conf{'DBDatabase'},$Conf{'DBTableParse'}, $Headers{'mid'}));
275 $DBHandle->disconnect;
277 print "------------------- DONE! -------------------\n" if $OptDebug;
280 ################################ Documentation #################################
284 parsedb - parse raw data and save it to a database
288 B<parsedb> [B<-Vht>] [B<--day> I<YYYY-MM-DD> | I<YYYY-MM-DD:YYYY-MM-DD>] [B<--rawdb> I<database table>] [B<--parsedb> I<database table>] [B<--conffile> I<filename>] [B<--debug>]
296 This script will parse raw, unstructured headers from a database table which is
297 fed from F<feedlog.pl> for a given time period and write its results to
298 nother database table with separate fields (columns) for most (or even all)
301 I<Subject:>, I<From:>, I<Sender:> and I<Reply-To:> will be parsed from MIME
302 encoded words to UTF-8 as needed while the unparsed copy is kept. From that
303 parsed copy, I<From:>, I<Sender:> and I<Reply-To:> will also be split into
304 separate name(s) and address(es) fields while the un-splitted copy is kept,
307 B<parsedb> should be run nightly from cron for yesterdays data so all
308 other scripts get current information. The time period to act on defaults to
309 yesterday, accordingly; you can assign another time period or a single day via
310 the B<--day> option (see below).
314 B<parsedb> will read its configuration from F<newsstats.conf>
315 should be present in etc/ via Config::Auto or from a configuration file
316 submitted by the B<--conffile> option.
318 See L<doc/INSTALL> for an overview of possible configuration options.
320 You can override configuration options via the B<--rawdb> and
321 B<--parsedb> options, respectively.
327 =item B<-V>, B<--version>
329 Print out version and copyright information and exit.
331 =item B<-h>, B<--help>
333 Print this man page and exit.
337 Output (rather much) debugging information to STDOUT while processing.
339 =item B<-t>, B<--test>
341 Do not write results to database. You should use B<--debug> in
342 conjunction with B<--test> ... everything else seems a bit pointless.
344 =item B<-d>, B<--day> I<YYYY-MM-DD[:YYYY-MM-DD]>
346 Set processing period to a single day in YYYY-MM-DD format or to a time
347 period between two days in YYYY-MM-DD:YYYY-MM-DD format (two days, separated
350 Defaults to yesterday.
352 =item B<--rawdb> I<table> (raw data table)
354 Override I<DBTableRaw> from F<newsstats.conf>.
356 =item B<--parsedb> I<table> (parsed data table)
358 Override I<DBTableParse> from F<newsstats.conf>.
360 =item B<--conffile> I<filename>
362 Load configuration from I<filename> instead of F<newsstats.conf>.
372 An example crontab entry:
374 0 1 * * * /path/to/bin/parsedb.pl
376 Do a dry run for yesterday's data, showing results of processing:
378 parsedb --debug --test | less
384 =item F<bin/parsedb.pl>
388 =item F<lib/NewsStats.pm>
390 Library functions for the NewsStats package.
392 =item F<etc/newsstats.conf>
394 Runtime configuration file.
400 Please report any bugs or feature requests to the author or use the
401 bug tracker at L<http://bugs.th-h.de/>!
417 This script is part of the B<NewsStats> package.
421 Thomas Hochstein <thh@inter.net>
423 =head1 COPYRIGHT AND LICENSE
425 Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
427 This program is free software; you may redistribute it and/or modify it
428 under the same terms as Perl itself.