#!/usr/bin/perl -w
use strict;
$|++;
my $VERSION = '0.07';
#----------------------------------------------------------------------------
=head1 NAME
cpanmail.cgi - script to access a tester's email address for a given report.
=head1 SYNOPSIS
perl cpanmail.cgi
=head1 DESCRIPTION
Given a report identifier, either as a report ID or a Metabase GUID, will
perform a look up to retrieve the tester's email address for the given report
identifier.
=cut
# -------------------------------------
# Library Modules
use CGI;
#use CGI::Carp qw(fatalsToBrowser);
use Config::IniFiles;
use CPAN::Testers::Common::DBUtils;
use Template;
# -------------------------------------
# Variables
my $LOG = 'logs/cpanstats.log';
my $CONFIG = './cpanmail.ini';
my %tvars;
# -------------------------------------
# Program
my $cgi = CGI->new();
my $id = $cgi->param('id'); # new style
if($id && $id =~ /^(\d+)$/) {
$tvars{id} = $1;
} elsif($id && $id =~ /^([-\w]+)$/) {
$tvars{guid} = $1;
}
my $found = 0;
if($tvars{id} || $tvars{guid}) {
if(-f $CONFIG) {
$found = retrieve_from_db(
id => $tvars{id},
guid => $tvars{guid}
);
}
$found ||= 5;
} else {
$found = 3;
}
$tvars{found} = $found;
write_results();
# -------------------------------------
# Subroutines
=item retrieve_from_db
Access the database and retrieve the required article data.
=cut
sub retrieve_from_db {
my %hash = @_;
my $cfg;
# load configuration file
local $SIG{'__WARN__'} = \&_alarm_handler;
eval { $cfg = Config::IniFiles->new( -file => $CONFIG ); };
return 0 unless($cfg && !$@);
# configure databases
my $db = 'CPANSTATS';
return 0 unless($cfg->SectionExists($db));
my %opts = map {my $v = $cfg->val($db,$_); defined($v) ? ($_ => $v) : () }
qw(driver database dbfile dbhost dbport dbuser dbpass);
my $dbh = CPAN::Testers::Common::DBUtils->new(%opts);
return 0 unless($dbh);
my $sql;
if(defined $hash{id}) {
$sql = "SELECT * FROM cpanstats WHERE id=$hash{id}";
} elsif(defined $hash{guid}) {
$sql = "SELECT * FROM cpanstats WHERE guid='$hash{guid}'";
}
my @rows = $dbh->get_query('hash',$sql);
return 0 unless(@rows);
$tvars{id} = $rows[0]->{id};
$tvars{guid} = $rows[0]->{guid};
$tvars{subject} = sprintf "%s %s-%s %s %s", uc $rows[0]->{state}, $rows[0]->{dist}, $rows[0]->{version}, $rows[0]->{perl}, $rows[0]->{osname};
$tvars{from} = $rows[0]->{tester};
return 1;
}
=item write_results
Outputs the results using Template Toolkit
=cut
sub write_results {
# deter spammers
if($tvars{from}) {
$tvars{from} =~ s/\@/ at /g;
$tvars{from} =~ s/\./ dot /g;
}
my %config = ( # provide config info
RELATIVE => 1,
ABSOLUTE => 1,
INCLUDE_PATH => '..',
INTERPOLATE => 0,
POST_CHOMP => 1,
TRIM => 1,
);
print $cgi->header;
my $parser = Template->new(\%config); # initialise parser
$parser->process('response.html',\%tvars) # parse the template
or die $parser->error();
}
sub _alarm_handler { return; }
__END__
=back
=head1 BUGS, PATCHES & FIXES
There are no known bugs at the time of this release. However, if you spot a
bug or are experiencing difficulties, that is not explained within the POD
documentation, please send an email to barbie@cpan.org. However, it would help
greatly if you are able to pinpoint problems or even supply a patch.
Fixes are dependant upon their severity and my availablity. Should a fix not
be forthcoming, please feel free to (politely) remind me.
=head1 SEE ALSO
L<CPAN::Testers::WWW::Statistics>.
F<http://stats.cpantesters.org/>
=head1 AUTHOR
Barbie, <barbie@cpan.org>
for Miss Barbell Productions <http://www.missbarbell.co.uk>.
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2005-2011 Barbie for Miss Barbell Productions.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut