[usenet/newsstats.git] / bin / parsedb.pl

#! /usr/bin/perl
#
# parsedb.pl
#
# This script will parse a database with raw header information
# from a INN feed to a structured database.
#
# It is part of the NewsStats package.
#
# Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
#
# It can be redistributed and/or modified under the same terms under
# which Perl itself is published.

BEGIN {
  our $VERSION = "0.01";
  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 :SQLHelper);

use DBI;
use Getopt::Long qw(GetOptions);
Getopt::Long::config ('bundling');

use Encode qw/decode/;
use Mail::Address;

################################# Definitions ##################################

# define header names with separate database fields
my %DBFields = ('date'                      => 'date',
                'references'                => 'refs',
                'followup-to'               => 'fupto',
                'from'                      => 'from_',
                'sender'                    => 'sender',
                'reply-to'                  => 'replyto',
                'subject'                   => 'subject',
                'organization'              => 'organization',
                'lines'                     => 'linecount',
                'approved'                  => 'approved',
                'supersedes'                => 'supersedes',
                'expires'                   => 'expires',
                'user-agent'                => 'useragent',
                'x-newsreader'              => 'xnewsreader',
                'x-mailer'                  => 'xmailer',
                'x-no-archive'              => 'xnoarchive',
                'content-type'              => 'contenttype',
                'content-transfer-encoding' => 'contentencoding',
                'cancel-lock'               => 'cancellock',
                'injection-info'            => 'injectioninfo',
                'x-trace'                   => 'xtrace',
                'nntp-posting-host'         => 'postinghost');

# define field list for database
my @DBFields = qw/day mid refs date path newsgroups fupto from_ from_parsed
                 from_name from_address sender sender_parsed sender_name
                 sender_address replyto replyto_parsed replyto_name
                 replyto_address subject subject_parsed organization linecount
                 approved supersedes expires useragent xnewsreader xmailer
                 xnoarchive contenttype contentencoding cancellock injectioninfo
                 xtrace postinghost headers disregard/;

################################# Main program #################################

### read commandline options
my ($OptDay,$OptDebug,$OptParseDB,$OptRawDB,$OptTest,$OptConfFile);
GetOptions ('d|day=s'         => \$OptDay,
            'debug!'          => \$OptDebug,
            'parsedb=s'       => \$OptParseDB,
            'rawdb=s'         => \$OptRawDB,
            't|test!'         => \$OptTest,
            'conffile=s'      => \$OptConfFile,
            'h|help'          => \&ShowPOD,
            'V|version'       => \&ShowVersion) or exit 1;

### read configuration
my %Conf = %{ReadConfig($OptConfFile)};

### override configuration via commandline options
my %ConfOverride;
$ConfOverride{'DBTableRaw'}   = $OptRawDB if $OptRawDB;
$ConfOverride{'DBTableParse'} = $OptParseDB if $OptParseDB;
&OverrideConfig(\%Conf,\%ConfOverride);

### get time period
### and set $Period for output and expression for SQL 'WHERE' clause
my ($Period,$SQLWherePeriod) = &GetTimePeriod($OptDay,'day');
# bail out if --month is invalid or "all"
&Bleat(2,"--day option has an invalid format - please use 'YYYY-MM-DD' or ".
         "'YYYY-MM-DD:YYYY-MM-DD'!") if (!$Period or $Period eq 'all time');

### init database
my $DBHandle = InitDB(\%Conf,1);

### get & write data
&Bleat(1,'Test mode. Database is not updated.') if $OptTest;

# create $SQLWhereClause
my $SQLWhereClause = SQLBuildClause('where',$SQLWherePeriod,'NOT disregard');

# delete old data for current period
if (!$OptTest) {
  print "----------- Deleting old data ... -----------\n" if $OptDebug;
  my $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s.%s %s",
                                     $Conf{'DBDatabase'},$Conf{'DBTableParse'},
                                     $SQLWhereClause))
      or &Bleat(2,sprintf("Can't delete old parsed data for %s from %s.%s: ".
                          "$DBI::errstr\n",$Period,
                          $Conf{'DBDatabase'},$Conf{'DBTableParse'}));
};

# read from DBTableRaw
print "-------------- Reading data ... -------------\n" if $OptDebug;
my $DBQuery = $DBHandle->prepare(sprintf("SELECT id, day, mid, peer, path, ".
                                         "newsgroups, headers, disregard ".
                                         "FROM %s.%s %s", $Conf{'DBDatabase'},
                                         $Conf{'DBTableRaw'}, $SQLWhereClause));
$DBQuery->execute()
  or &Bleat(2,sprintf("Can't get data for %s from %s.%s: ".
                      "$DBI::errstr\n",$Period,
                      $Conf{'DBDatabase'},$Conf{'DBTableRaw'}));

# set output and database connection to UTF-8
# as we're going to write decoded header contents containing UTF-8 chars
binmode(STDOUT, ":utf8");
$DBHandle->do("SET NAMES 'utf8'");

# create a list of supported encondings
my %LegalEncodings;
foreach (Encode->encodings()) {
  $LegalEncodings{$_} = 1;
}
# parse data in a loop and write it out
print "-------------- Parsing data ... -------------\n" if $OptDebug;
while (my $HeadersR = $DBQuery->fetchrow_hashref) {
  my %Headers = %{$HeadersR};

  # parse $Headers{'headers'} ('headers' from DBTableRaw)
  # remove empty lines (that should not even exist in a header!)
  $Headers{'headers'} =~ s/\n\s*\n/\n/g;
  # merge continuation lines
  # from Perl Cookbook, 1st German ed. 1999, pg. 91
  $Headers{'headers'} =~ s/\n\s+/ /g;
  # split headers in single lines
  my $OtherHeaders;
  for (split(/\n/,$Headers{'headers'})) {
    # split header lines in header name and header content
    my ($key,$value);
    if ($_ =~ /:/) {
      ($key,$value) = split(/:/,$_,2);
      $key =~ s/\s*//;
      $value =~ s/^\s*(.+)\s*$/$1/;
    } else {
      &Bleat(1,sprintf("Illegal header line in %s.%s id %s: %s",
                       $Conf{'DBDatabase'}, $Conf{'DBTableRaw'},
                       $Headers{'id'},$_));
      next;
    }
    # check for empty (mandatory) fields from DBTableRaw
    # and set them from $Headers{'headers', if necessary
    if (lc($key) =~ /^(message-id|path|newsgroups)$/) {
      my $HeaderName = lc($key);
      $HeaderName    = 'mid' if ($HeaderName eq 'message-id');
      if (!defined($Headers{$HeaderName}) or $Headers{$HeaderName} eq '') {
        $Headers{$HeaderName} = $value;
        &Bleat(1,sprintf("Taking missing %s from 'headers' in %s.%s id %s.",
                         $HeaderName, $Conf{'DBDatabase'}, $Conf{'DBTableRaw'},
                         $Headers{'id'}));
      }
    }
    # save each header, separate database fields in %Headers,
    # the rest in $OtherHeaders (but not Message-ID, Path, Peer
    # and Newsgroups as those do already exist)
    if (defined($DBFields{lc($key)})) {
      $Headers{$DBFields{lc($key)}} = $value;
    } else {
      $OtherHeaders .= sprintf("%s: %s\n",$key,$value)
        if lc($key) !~ /^(message-id|path|peer|newsgroups)$/;
    }
  }
  # replace old (now parsed) $Headers{'headers'} with remanining $OtherHeaders
  chomp($OtherHeaders);
  $Headers{'headers'} = $OtherHeaders;

  foreach ('from_','sender', 'replyto', 'subject') {
    if ($Headers{$_}) {
      my $HeaderName = $_;
      $HeaderName  =~ s/_$//;
      # decode From: / Sender: / Reply-To: / Subject:
      if ($Headers{$_} =~ /\?(B|Q)\?/) {
        # check for legal encoding and decode
        (my $Encoding) = $Headers{$_} =~ /\?([^?]+)\?(B|Q)\?/;
        $Headers{$HeaderName.'_parsed'} = decode('MIME-Header',$Headers{$_})
          if (exists($LegalEncodings{$Encoding}));
      }
      # extract name(s) and mail(s) from From: / Sender: / Reply-To:
      # in parsed form, if available
      if ($_ ne 'subject') {
        my @Address;
        # start parser on header or parsed header
        # @Address will have an array of Mail::Address objects, one for
        # each name/mail (you can have more than one person in From:!)
        if (defined($Headers{$HeaderName.'_parsed'})) {
          @Address = Mail::Address->parse($Headers{$HeaderName.'_parsed'});
        } else {
          @Address = Mail::Address->parse($Headers{$_});
        }
        # split each Mail::Address object to @Names and @Adresses
        my (@Names,@Adresses);
        foreach (@Address) {
          # take address part in @Addresses
          push (@Adresses, $_->address());
          # take name part form "phrase", if there is one:
          # From: My Name <addr@ess> (Comment)
          # otherwise, take it from "comment":
          # From: addr@ess (Comment)
          # and push it in @Names
          my ($Name);
          $Name = $_->comment() unless $Name = $_->phrase;
          $Name =~ s/^\((.+)\)$/$1/;
          push (@Names, $Name);
        }
        # put all @Adresses and all @Names in %Headers as comma separated lists
        $Headers{$HeaderName.'_address'} = join(', ',@Adresses);
        $Headers{$HeaderName.'_name'}    = join(', ',@Names);
      }
    }
  }

  # order output for database entry: fill @SQLBindVars
  print "-------------- Next entry:\n" if $OptDebug;
  my @SQLBindVars;
  foreach (@DBFields) {
    if (defined($Headers{$_}) and $Headers{$_} ne '') {
      push (@SQLBindVars,$Headers{$_});
      printf ("FOUND: %s -> %s\n",$_,$Headers{$_}) if $OptDebug;
    } else {
      push (@SQLBindVars,undef);
    }
  }

  # write data to DBTableParse
  if (!$OptTest) {
    print "-------------- Writing data ... -------------\n" if $OptDebug;
    my $DBWrite =
       $DBHandle->prepare(sprintf("INSERT INTO %s.%s (%s) VALUES (%s)",
                                  $Conf{'DBDatabase'},
                                  $Conf{'DBTableParse'},
                                  # get field names from @DBFields
                                  join(', ',@DBFields),
                                  # create a list of '?' for each DBField
                                  join(', ',
                                       split(/ /,'? ' x scalar(@DBFields)))
                                ));
  $DBWrite->execute(@SQLBindVars)
      or &Bleat(2,sprintf("Can't write parsed data for %s to %s.%s for %s: ".
                          "$DBI::errstr\n",$Period,
                          $Conf{'DBDatabase'},$Conf{'DBTableParse'}, $Headers{'mid'}));
    $DBWrite->finish;
  }
};
$DBQuery->finish;

### close handles
$DBHandle->disconnect;

print "------------------- DONE! -------------------\n" if $OptDebug;
__END__

################################ Documentation #################################

=head1 NAME

parsedb - parse raw data and save it to a database

=head1 SYNOPSIS

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>]

=head1 REQUIREMENTS

See L<doc/README>.

=head1 DESCRIPTION

This script will parse raw, unstructured headers from a database table which is
fed from F<feedlog.pl> for a given time period and write its results to
nother database table with separate fields (columns) for most (or even all)
relevant headers.

I<Subject:>, I<From:>, I<Sender:> and I<Reply-To:> will be parsed from MIME
encoded words to UTF-8 as needed while the unparsed copy is kept. From that
parsed copy, I<From:>, I<Sender:> and I<Reply-To:> will also be split into
separate name(s) and address(es) fields while the un-splitted copy is kept,
too.

B<parsedb> should be run nightly from cron for yesterdays data so all
other scripts get current information. The time period to act on defaults to
yesterday, accordingly; you can assign another time period or a single day via
the B<--day> option (see below).

=head2 Configuration

B<parsedb> will read its configuration from F<newsstats.conf>
should be present in etc/ via Config::Auto or from a configuration file
submitted by the B<--conffile> option.

See L<doc/INSTALL> for an overview of possible configuration options.

You can override configuration options via the B<--rawdb> and
B<--parsedb> options, respectively.

=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<--debug>

Output (rather much) debugging information to STDOUT while processing.

=item B<-t>, B<--test>

Do not write results to database. You should use B<--debug> in
conjunction with B<--test> ... everything else seems a bit pointless.

=item B<-d>, B<--day> I<YYYY-MM-DD[:YYYY-MM-DD]>

Set processing period to a single day in YYYY-MM-DD format or to a time
period between two days in YYYY-MM-DD:YYYY-MM-DD format (two days, separated
by a colon).

Defaults to yesterday.

=item B<--rawdb> I<table> (raw data table)

Override I<DBTableRaw> from F<newsstats.conf>.

=item B<--parsedb> I<table> (parsed data table)

Override I<DBTableParse> from F<newsstats.conf>.

=item B<--conffile> I<filename>

Load configuration from I<filename> instead of F<newsstats.conf>.

=back

=head1 INSTALLATION

See L<doc/INSTALL>.

=head1 EXAMPLES

An example crontab entry:

    0 1 * * * /path/to/bin/parsedb.pl

Do a dry run for yesterday's data, showing results of processing:

    parsedb --debug --test | less

=head1 FILES

=over 4

=item F<bin/parsedb.pl>

The script itself.

=item F<lib/NewsStats.pm>

Library functions for the NewsStats package.

=item F<etc/newsstats.conf>

Runtime configuration file.

=back

=head1 BUGS

Please report any bugs or feature requests to the author or use the
bug tracker at L<http://bugs.th-h.de/>!

=head1 SEE ALSO

=over 2

=item -

L<doc/README>

=item -

L<doc/INSTALL>

=back

This script is part of the B<NewsStats> package.

=head1 AUTHOR

Thomas Hochstein <thh@inter.net>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2013 Thomas Hochstein <thh@inter.net>

This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=cut
Commit	Line	Data
6d72dad2 TH	1	#! /usr/bin/perl
	2	#
	3	# parsedb.pl
	4	#
	5	# This script will parse a database with raw header information
	6	# from a INN feed to a structured database.
	7	#
	8	# It is part of the NewsStats package.
	9	#
	10	# Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
	11	#
	12	# It can be redistributed and/or modified under the same terms under
	13	# which Perl itself is published.
	14
	15	BEGIN {
	16	our $VERSION = "0.01";
	17	use File::Basename;
	18	# we're in .../bin, so our module is in ../lib
	19	push(@INC, dirname($0).'/../lib');
	20	}
	21	use strict;
	22	use warnings;
	23
	24	use NewsStats qw(:DEFAULT :TimePeriods :SQLHelper);
	25
	26	use DBI;
	27	use Getopt::Long qw(GetOptions);
	28	Getopt::Long::config ('bundling');
	29
9630376c TH	30	use Encode qw/decode/;
	31	use Mail::Address;
	32
6d72dad2 TH	33	################################# Definitions ##################################
	34
	35	# define header names with separate database fields
	36	my %DBFields = ('date' => 'date',
	37	'references' => 'refs',
	38	'followup-to' => 'fupto',
	39	'from' => 'from_',
	40	'sender' => 'sender',
	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');
	58
	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/;
	67
	68	################################# Main program #################################
	69
	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;
	80
	81	### read configuration
	82	my %Conf = %{ReadConfig($OptConfFile)};
	83
	84	### override configuration via commandline options
	85	my %ConfOverride;
	86	$ConfOverride{'DBTableRaw'} = $OptRawDB if $OptRawDB;
	87	$ConfOverride{'DBTableParse'} = $OptParseDB if $OptParseDB;
	88	&OverrideConfig(\%Conf,\%ConfOverride);
	89
	90	### get time period
	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');
	96
97	### init database
98	my $DBHandle = InitDB(\%Conf,1);
99
100	### get & write data
101	&Bleat(1,'Test mode. Database is not updated.') if $OptTest;
102
103	# create $SQLWhereClause
104	my $SQLWhereClause = SQLBuildClause('where',$SQLWherePeriod,'NOT disregard');
105
106	# delete old data for current period
107	if (!$OptTest) {
108	print "----------- Deleting old data ... -----------\n" if $OptDebug;
109	my $DBQuery = $DBHandle->do(sprintf("DELETE FROM %s.%s %s",
110	$Conf{'DBDatabase'},$Conf{'DBTableParse'},
111	$SQLWhereClause))
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'}));
115	};
116
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));
123	$DBQuery->execute()
124	or &Bleat(2,sprintf("Can't get data for %s from %s.%s: ".
125	"$DBI::errstr\n",$Period,
126	$Conf{'DBDatabase'},$Conf{'DBTableRaw'}));
127
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'");
132
48c8d4bb TH	133	# create a list of supported encondings
	134	my %LegalEncodings;
	135	foreach (Encode->encodings()) {
	136	$LegalEncodings{$_} = 1;
	137	}
6d72dad2 TH	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};
	142
	143	# parse $Headers{'headers'} ('headers' from DBTableRaw)
48c8d4bb TH	144	# remove empty lines (that should not even exist in a header!)
48c8d4bb TH	145	$Headers{'headers'} =~ s/\n\s*\n/\n/g;
6d72dad2 TH	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
	150	my $OtherHeaders;
	151	for (split(/\n/,$Headers{'headers'})) {
	152	# split header lines in header name and header content
48c8d4bb TH	153	my ($key,$value);
	154	if ($_ =~ /:/) {
	155	($key,$value) = split(/:/,$_,2);
	156	$key =~ s/\s*//;
	157	$value =~ s/^\s(.+)\s$/$1/;
	158	} else {
	159	&Bleat(1,sprintf("Illegal header line in %s.%s id %s: %s",
	160	$Conf{'DBDatabase'}, $Conf{'DBTableRaw'},
	161	$Headers{'id'},$_));
	162	next;
	163	}
	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'},
	173	$Headers{'id'}));
	174	}
	175	}
6d72dad2 TH	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;
	181	} else {
	182	$OtherHeaders .= sprintf("%s: %s\n",$key,$value)
	183	if lc($key) !~ /^(message-id\|path\|peer\|newsgroups)$/;
	184	}
	185	}
	186	# replace old (now parsed) $Headers{'headers'} with remanining $OtherHeaders
	187	chomp($OtherHeaders);
	188	$Headers{'headers'} = $OtherHeaders;
	189
9630376c TH	190	foreach ('from_','sender', 'replyto', 'subject') {
	191	if ($Headers{$_}) {
	192	my $HeaderName = $_;
	193	$HeaderName =~ s/_$//;
	194	# decode From: / Sender: / Reply-To: / Subject:
	195	if ($Headers{$_} =~ /\?(B\|Q)\?/) {
48c8d4bb TH	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}));
9630376c TH	200	}
	201	# extract name(s) and mail(s) from From: / Sender: / Reply-To:
	202	# in parsed form, if available
	203	if ($_ ne 'subject') {
	204	my @Address;
	205	# start parser on header or parsed header
	206	# @Address will have an array of Mail::Address objects, one for
	207	# each name/mail (you can have more than one person in From:!)
	208	if (defined($Headers{$HeaderName.'_parsed'})) {
	209	@Address = Mail::Address->parse($Headers{$HeaderName.'_parsed'});
	210	} else {
	211	@Address = Mail::Address->parse($Headers{$_});
	212	}
aef5467b TH	213	# split each Mail::Address object to @Names and @Adresses
aef5467b TH	214	my (@Names,@Adresses);
9630376c	215	foreach (@Address) {
aef5467b TH	216	# take address part in @Addresses
aef5467b TH	217	push (@Adresses, $_->address());
9630376c TH	218	# take name part form "phrase", if there is one:
	219	# From: My Name <addr@ess> (Comment)
	220	# otherwise, take it from "comment":
	221	# From: addr@ess (Comment)
aef5467b TH	222	# and push it in @Names
	223	my ($Name);
	224	$Name = $_->comment() unless $Name = $_->phrase;
	225	$Name =~ s/^\((.+)\)$/$1/;
	226	push (@Names, $Name);
9630376c	227	}
aef5467b TH	228	# put all @Adresses and all @Names in %Headers as comma separated lists
	229	$Headers{$HeaderName.'_address'} = join(', ',@Adresses);
	230	$Headers{$HeaderName.'_name'} = join(', ',@Names);
9630376c TH	231	}
	232	}
	233	}
	234
6d72dad2 TH	235	# order output for database entry: fill @SQLBindVars
	236	print "-------------- Next entry:\n" if $OptDebug;
	237	my @SQLBindVars;
	238	foreach (@DBFields) {
	239	if (defined($Headers{$_}) and $Headers{$_} ne '') {
	240	push (@SQLBindVars,$Headers{$_});
	241	printf ("FOUND: %s -> %s\n",$_,$Headers{$_}) if $OptDebug;
	242	} else {
	243	push (@SQLBindVars,undef);
	244	}
	245	}
	246
	247	# write data to DBTableParse
	248	if (!$OptTest) {
	249	print "-------------- Writing data ... -------------\n" if $OptDebug;
	250	my $DBWrite =
	251	$DBHandle->prepare(sprintf("INSERT INTO %s.%s (%s) VALUES (%s)",
	252	$Conf{'DBDatabase'},
	253	$Conf{'DBTableParse'},
	254	# get field names from @DBFields
	255	join(', ',@DBFields),
	256	# create a list of '?' for each DBField
	257	join(', ',
	258	split(/ /,'? ' x scalar(@DBFields)))
	259	));
	260	$DBWrite->execute(@SQLBindVars)
6deb7dba	261	or &Bleat(2,sprintf("Can't write parsed data for %s to %s.%s for %s: ".
6d72dad2	262	"$DBI::errstr\n",$Period,
6deb7dba	263	$Conf{'DBDatabase'},$Conf{'DBTableParse'}, $Headers{'mid'}));
6d72dad2 TH	264	$DBWrite->finish;
	265	}
	266	};
	267	$DBQuery->finish;
	268
	269	### close handles
	270	$DBHandle->disconnect;
	271
	272	print "------------------- DONE! -------------------\n" if $OptDebug;
	273	__END__
	274
	275	################################ Documentation #################################
	276
	277	=head1 NAME
	278
	279	parsedb - parse raw data and save it to a database
	280
	281	=head1 SYNOPSIS
	282
	283	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>]
	284
	285	=head1 REQUIREMENTS
	286
	287	See L<doc/README>.
	288
	289	=head1 DESCRIPTION
	290
13e00610 TH	291	This script will parse raw, unstructured headers from a database table which is
	292	fed from F<feedlog.pl> for a given time period and write its results to
	293	nother database table with separate fields (columns) for most (or even all)
	294	relevant headers.
	295
	296	I<Subject:>, I<From:>, I<Sender:> and I<Reply-To:> will be parsed from MIME
	297	encoded words to UTF-8 as needed while the unparsed copy is kept. From that
	298	parsed copy, I<From:>, I<Sender:> and I<Reply-To:> will also be split into
	299	separate name(s) and address(es) fields while the un-splitted copy is kept,
	300	too.
	301
	302	B<parsedb> should be run nightly from cron for yesterdays data so all
	303	other scripts get current information. The time period to act on defaults to
	304	yesterday, accordingly; you can assign another time period or a single day via
	305	the B<--day> option (see below).
6d72dad2 TH	306
	307	=head2 Configuration
	308
13e00610 TH	309	B<parsedb> will read its configuration from F<newsstats.conf>
	310	should be present in etc/ via Config::Auto or from a configuration file
	311	submitted by the B<--conffile> option.
	312
	313	See L<doc/INSTALL> for an overview of possible configuration options.
	314
	315	You can override configuration options via the B<--rawdb> and
	316	B<--parsedb> options, respectively.
6d72dad2 TH	317
	318	=head1 OPTIONS
	319
	320	=over 3
	321
	322	=item B<-V>, B<--version>
	323
	324	Print out version and copyright information and exit.
	325
	326	=item B<-h>, B<--help>
	327
	328	Print this man page and exit.
	329
	330	=item B<--debug>
	331
	332	Output (rather much) debugging information to STDOUT while processing.
	333
	334	=item B<-t>, B<--test>
	335
	336	Do not write results to database. You should use B<--debug> in
	337	conjunction with B<--test> ... everything else seems a bit pointless.
	338
	339	=item B<-d>, B<--day> I<YYYY-MM-DD[:YYYY-MM-DD]>
	340
	341	Set processing period to a single day in YYYY-MM-DD format or to a time
	342	period between two days in YYYY-MM-DD:YYYY-MM-DD format (two days, separated
	343	by a colon).
	344
	345	Defaults to yesterday.
	346
	347	=item B<--rawdb> I<table> (raw data table)
	348
	349	Override I<DBTableRaw> from F<newsstats.conf>.
	350
	351	=item B<--parsedb> I<table> (parsed data table)
	352
	353	Override I<DBTableParse> from F<newsstats.conf>.
	354
	355	=item B<--conffile> I<filename>
	356
	357	Load configuration from I<filename> instead of F<newsstats.conf>.
	358
	359	=back
	360
	361	=head1 INSTALLATION
	362
	363	See L<doc/INSTALL>.
	364
	365	=head1 EXAMPLES
	366
13e00610 TH	367	An example crontab entry:
	368
	369	0 1 * * * /path/to/bin/parsedb.pl
	370
	371	Do a dry run for yesterday's data, showing results of processing:
	372
	373	parsedb --debug --test \| less
6d72dad2 TH	374
	375	=head1 FILES
	376
	377	=over 4
	378
	379	=item F<bin/parsedb.pl>
	380
	381	The script itself.
	382
	383	=item F<lib/NewsStats.pm>
	384
	385	Library functions for the NewsStats package.
	386
	387	=item F<etc/newsstats.conf>
	388
	389	Runtime configuration file.
	390
	391	=back
	392
	393	=head1 BUGS
	394
	395	Please report any bugs or feature requests to the author or use the
	396	bug tracker at L<http://bugs.th-h.de/>!
	397
	398	=head1 SEE ALSO
	399
	400	=over 2
	401
	402	=item -
	403
	404	L<doc/README>
	405
	406	=item -
	407
	408	L<doc/INSTALL>
	409
	410	=back
	411
	412	This script is part of the B<NewsStats> package.
	413
	414	=head1 AUTHOR
	415
	416	Thomas Hochstein <thh@inter.net>
	417
	418	=head1 COPYRIGHT AND LICENSE
	419
	420	Copyright (c) 2013 Thomas Hochstein <thh@inter.net>
	421
	422	This program is free software; you may redistribute it and/or modify it
	423	under the same terms as Perl itself.
	424
	425	=cut