Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

First version

  • Loading branch information...
commit e507a5ecba4446c062a58da5f082a0bf7ee63795 0 parents
barbie authored
4 CHANGES
@@ -0,0 +1,4 @@
+Revision history for Perl module CPAN::Testers::WWW::Reports::Mailer.
+
+0.01 08/09/2008
+ - initial release
14 MANIFEST
@@ -0,0 +1,14 @@
+bin/cpanstats-mailer
+CHANGES
+data/example-settings.ini
+lib/CPAN/Testers/WWW/Reports/Mailer.pm
+lib/CPAN/Testers/WWW/Reports/Mailer/DBUtils.pm
+Makefile.PL
+MANIFEST
+META.yml
+t/01base.t
+t/90podtest.t
+t/91podcover.t
+t/94metatest.t
+templates/mailer.eml
+templates/notification.eml
55 META.yml
@@ -0,0 +1,55 @@
+--- #YAML:1.0
+name: CPAN-Testers-WWW-Reports-Mailer
+version: 0.26
+abstract: CPAN Testers Reports Mailer toolset
+author:
+ - Barbie <barbie@cpan.org>
+
+license: perl
+distribution_type: module
+installdirs: site
+
+requires:
+ Cwd: 0
+ CPAN::DistnameInfo: 0
+ Class::Accessor::Fast: 0
+ DBD::SQLite: 1.07
+ DBI: 0
+ Email::Simple: 0
+ File::Basename: 0
+ File::Path: 0
+ Getopt::Long: 0
+ MIME::Base64: 0
+ MIME::QuotedPrint: 0
+ Net::NNTP: 0
+ version: 0
+recommends:
+ Test::More: 0.70
+ Test::MockObject: 0
+ Test::Pod: 1.00
+ Test::Pod::Coverage: 0.08
+ Test::CPAN::Meta: 0.12
+build_requires:
+ Test::More: 0.01
+
+provides:
+ CPAN::Testers::WWW::Reports::Mailer:
+ file: lib/CPAN/Testers/WWW/Reports/Mailer.pm
+ version: 0.01
+ CPAN::Testers::WWW::Reports::Mailer::DBUtils:
+ file: lib/CPAN/Testers/WWW/Reports/Mailer/DBUtils.pm
+ version: 0.01
+
+no_index:
+ directory:
+ - t
+ - examples
+
+resources:
+ license: http://dev.perl.org/licenses/
+ bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Testers-WWW-Reports-Mailer
+
+meta-spec:
+ version: 1.4
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+generated_by: Hand 1.0
28 Makefile.PL
@@ -0,0 +1,28 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ 'NAME' => 'CPAN::Testers::WWW::Reports::Mailer',
+ 'VERSION_FROM' => 'lib/CPAN/Testers/WWW/Reports/Mailer.pm',
+ 'PREREQ_PM' => {
+ 'Cwd' => 0, # only for cpanstats.pl
+ 'Getopt::Long' => 0, # only for cpanstats.pl
+
+ 'Class::Accessor::Fast' => 0,
+ 'CPAN::DistnameInfo' => 0,
+ 'DBD::mysql' => 0,
+ 'DBD::SQLite' => '1.07',
+ 'DBI' => 0,
+ 'Email::Simple' => 0,
+ 'File::Basename' => 0,
+ 'File::Path' => 0,
+
+ 'Test::More' => 0, # only for testing
+ },
+ 'PL_FILES' => {},
+ 'INSTALLDIRS' => 'site',
+ 'EXE_FILES' => [ 'bin/cpanstats-mailer' ],
+ NO_META => 1,
+
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT => 'CPAN Testers Reports Mailer toolset',
+ AUTHOR => 'Barbie <barbie@cpan.org>') : ()),
+);
457 bin/cpanstats-mailer
@@ -0,0 +1,457 @@
+#!/usr/bin/perl
+use strict;
+$|++;
+
+my $VERSION = '0.01';
+
+#----------------------------------------------------------------------------
+
+=head1 NAME
+
+cpanstats-mailer - script to mail authors links to reports of their modules
+
+=head1 SYNOPSIS
+
+ perl cpanstats-mailer --config=prefs.ini
+
+=head1 DESCRIPTION
+
+Collates report links for each author, based on the preferences set for each
+author, and mails them a single report. This script is expected to run daily
+and in tests produces only 40% of the previous mail volumes to authors.
+
+=cut
+
+# -------------------------------------
+# Library Modules
+
+use lib qw(./lib ../lib);
+
+use Compress::Zlib;
+use Config::IniFiles;
+use File::Basename;
+use File::Slurp;
+use Getopt::ArgvFile default=>1;
+use Getopt::Long;
+use LWP::UserAgent;
+use Path::Class;
+use Parse::CPAN::Authors;
+use Template;
+use WWW::Mechanize;
+
+use CPAN::Testers::WWW::Reports::Mailer::DBUtils;
+
+# -------------------------------------
+# Variables
+
+my (%options,%authors,%prefs);
+my (%counts);
+
+use constant LASTMAIL => '_lastmail';
+
+my $HOW = '/usr/sbin/sendmail -bm';
+my $HEAD = 'To: "NAME" <EMAIL>
+From: CPAN Tester Report Server <do_not_reply@cpantesters.org>
+Date: DATE
+Subject: SUBJECT
+
+';
+
+my @dotw = ( "Sunday", "Monday", "Tuesday", "Wednesday",
+ "Thursday", "Friday", "Saturday" );
+
+my @months = (
+ { 'id' => 1, 'value' => "January", },
+ { 'id' => 2, 'value' => "February", },
+ { 'id' => 3, 'value' => "March", },
+ { 'id' => 4, 'value' => "April", },
+ { 'id' => 5, 'value' => "May", },
+ { 'id' => 6, 'value' => "June", },
+ { 'id' => 7, 'value' => "July", },
+ { 'id' => 8, 'value' => "August", },
+ { 'id' => 9, 'value' => "September", },
+ { 'id' => 10, 'value' => "October", },
+ { 'id' => 11, 'value' => "November", },
+ { 'id' => 12, 'value' => "December" },
+);
+
+# -------------------------------------
+# Program
+
+init_options();
+check_reports();
+
+printf( "COUNT: %s\n", emaildate());
+printf( "%7s = %6d\n", $_, $counts{$_} ) for(keys %counts);
+
+# -------------------------------------
+# Functions
+
+sub check_reports {
+ my $last_id = get_lastid();
+ my (%reports,%tvars);
+
+ # find all reports since last update
+ my @rows = $options{cpanstats}->GetQuery('array',"SELECT id,dist,version,platform,perl,state FROM cpanstats WHERE id > $last_id AND state NOT IN ('cpan') ORDER BY id");
+ return unless(@rows);
+
+ for my $row (@rows) {
+ $counts{REPORTS}++;
+ $last_id = $row->[0];
+ $row->[5] = uc $row->[5];
+ $counts{$row->[5]}++;
+ my $author = get_author($row->[1], $row->[2]) || next;
+
+ # get author preferences
+ my $prefs = get_prefs($author) || next;
+
+ # do we need to worry about this author?
+ if($prefs->{active} == 2) {
+ $counts{NOMAIL}++;
+ next;
+ }
+
+ # get distribution preferences
+ $prefs = get_prefs($author, $row->[1]) || next;
+ next if($prefs->{actions}{'NONE'});
+ next unless($prefs->{actions}{$row->[5]});
+
+ # check whether only first instance required
+ if($prefs->{tuple} eq 'FIRST') {
+ my @count = $options{cpanstats}->GetQuery('array',"SELECT count(id) FROM cpanstats WHERE platform=? AND perl=? AND state=? AND id < ?",
+ $row->[3], $row->[4], $row->[5], $row->[0]);
+ next if($count[0]->[0] > 1);
+ }
+
+ # TODO:
+ # if set to 'ALL' check this is the current distribution
+ # 'OLD' should allow EVERYTHING through!
+
+ push @{$reports{$author}->{dists}{$row->[1]}->{versions}{$row->[2]}->{platforms}{$row->[3]}->{perls}{$row->[4]}->{states}{uc $row->[5]}->{value}}, $row->[0];
+ }
+
+ for my $author (keys %reports) {
+ my $pause = $options{pause}->author($author);
+ $tvars{name} = $pause->name;
+ $tvars{author} = $author;
+ $tvars{dists} = ();
+
+ # get author preferences
+ my $prefs = get_prefs($author);
+
+ # active:
+ # 0 - new author, no correspondance
+ # 1 - new author, notification mailed
+ # 2 - author requested no mail
+ # 3 - author active
+ if(!$prefs->{active} || $prefs->{active} == 0) {
+ $tvars{subject} = 'Welcome to CPAN Testers';
+ write_mail('notification.eml',\%tvars);
+ update_preferences($author);
+ }
+
+ my ($reports,@e);
+ for my $dist (keys %{$reports{$author}->{dists}}) {
+ my $v = $reports{$author}->{dists}{$dist};
+ my @d;
+ for my $version (keys %{$v->{versions}}) {
+ my $w = $v->{versions}{$version};
+ my @c;
+ for my $platform (keys %{$w->{platforms}}) {
+ my $x = $w->{platforms}{$platform};
+ my @b;
+ for my $perl (keys %{$x->{perls}}) {
+ my $y = $x->{perls}{$perl};
+ my @a;
+ for my $state (keys %{$y->{states}}) {
+ my $z = $y->{states}{$state};
+ push @a, {state => $state, ids => $z->{value}};
+ $reports++;
+ }
+ push @b, {perl => $perl, states => \@a};
+ }
+ push @c, {platform => $platform, perls => \@b};
+ }
+ push @d, {version => $version, platforms => \@c};
+ }
+ push @e, {dist => $dist, versions => \@d};
+ }
+
+ next unless($reports);
+
+ $tvars{dists} = \@e;
+ $tvars{subject} = 'CPAN Testers Daily Report';
+
+ write_mail('mailer.eml',\%tvars);
+ }
+
+ get_lastid($last_id);
+}
+
+sub get_lastid {
+ my $id = shift;
+
+ overwrite_file( LASTMAIL, 0 ) unless -f LASTMAIL;
+
+ if ($id) {
+ overwrite_file( LASTMAIL, $id );
+ } else {
+ my $id = read_file(LASTMAIL);
+ return $id;
+ }
+}
+
+sub get_author {
+ my ($dist,$vers) = @_;
+
+ unless($authors{$dist}{$vers}) {
+ my @author = $options{cpanstats}->GetQuery('array',"SELECT tester FROM cpanstats WHERE dist=? AND version=? AND state='cpan' LIMIT 1", $dist, $vers);
+ $authors{$dist}{$vers} = $author[0]->[0];
+ }
+ return $authors{$dist}{$vers};
+}
+
+
+sub get_prefs {
+ my ($author,$dist) = @_;
+
+ # get distribution defaults
+ if($author && $dist) {
+ if(defined $prefs{$author}{dists}{$dist}) {
+ return $prefs{$author}{dists}{$dist};
+ }
+
+ my @rows = $options{authors}->GetQuery('hash',"SELECT action,tuple FROM prefs_distributions WHERE pauseid=? AND distribution=?", $author,$dist);
+ if(@rows) {
+ $rows[0]->{action} ||= 'FAIL';
+ my %actions = map {$_ => 1} split(',',$rows[0]->{action});
+ $prefs{$author}{dists}{$dist}{actions} = \%actions;
+ $prefs{$author}{dists}{$dist}{tuple} = $rows[0]->{tuple} || 'FIRST';
+ return $prefs{$author}{dists}{$dist};
+ }
+
+ # fall through and assume author defaults
+ }
+
+ # get author defaults
+ if($author) {
+ if(defined $prefs{$author}{default}) {
+ return $prefs{$author}{default};
+ }
+
+ my @rows = $options{authors}->GetQuery('hash',"SELECT active,action,tuple FROM prefs_authors WHERE pauseid=?", $author);
+ if(@rows) {
+ $rows[0]->{action} ||= 'FAIL';
+ my %actions = map {$_ => 1} split(',',$rows[0]->{action});
+ $prefs{$author}{default}{actions} = \%actions;
+ $prefs{$author}{default}{tuple} = $rows[0]->{tuple} || 'FIRST';
+ $prefs{$author}{default}{active} = $rows[0]->{active} || 0;
+ return $prefs{$author}{default};
+ }
+
+ # fall through and assume new author
+ }
+
+ # use global defaults
+ my %prefs = (actions => {'FAIL' => 1}, tuple => 'FIRST', active => 0);
+ return \%prefs;
+}
+
+sub write_mail {
+ my ($template,$parms) = @_;
+ my ($text);
+
+ my $subject = $parms->{subject} || 'CPAN Testers Daily Reports';
+
+ $counts{MAILS}++;
+#print "$parms->{author} - $subject\n";
+#return;
+
+ my $DATE = emaildate();
+ $DATE =~ s/\s+$//;
+
+ $options{tt}->process( $template, $parms, \$text ) || die $options{tt}->error;
+
+ my $cmd = qq!| $HOW $parms->{author}\@cpan.org!;
+ my $body = $HEAD . $text;
+ $body =~ s/NAME/$parms->{name}/g;
+ $body =~ s/EMAIL/$parms->{author}\@cpan.org/g;
+ $body =~ s/DATE/$DATE/g;
+ $body =~ s/SUBJECT/$subject/g;
+
+print "$body\n";
+return;
+
+ if(my $fh = IO::File->new($cmd)) {
+ print $fh $body;
+ $fh->close;
+ print "GOOD: $parms->{author}\n";
+ } else {
+ print "BAD: $parms->{author}\n";
+ }
+}
+
+sub update_preferences {
+ my $author = shift;
+
+ my @rows = $options{authors}->GetQuery('hash',"SELECT * FROM prefs_authors WHERE pauseid=?", $author);
+ if(@rows) {
+ $options{authors}->DoQuery('UPDATE prefs_authors SET active=1,lastlogin=? WHERE pauseid=?', time(), $author);
+ } else {
+ $options{authors}->DoQuery("INSERT INTO prefs_authors (pauseid,active,lastlogin,action,tuple) VALUES (?,1,?,'FAIL','FIRST')", $author, time());
+ }
+}
+
+sub init_options {
+ GetOptions( \%options,
+ 'config=s',
+ 'help|h',
+ 'version|V'
+ );
+
+ _help(1) if($options{help});
+ _help(0) if($options{version});
+
+ die "Configuration file [$options{config}] not found\n" unless(-f $options{config});
+
+ # load configuration
+ my $cfg = Config::IniFiles->new( -file => $options{config} );
+
+ # configure cpanstats DB
+ my %opts = map {$_ => $cfg->val('CPANSTATS',$_);} qw(driver database dbfile dbhost dbport dbuser dbpass);
+ $options{cpanstats} = CPAN::Testers::WWW::Reports::Mailer::DBUtils->new(%opts);
+
+ # configure preferences db
+ %opts = map {$_ => $cfg->val('AUTHORS',$_);} qw(driver database dbfile dbhost dbport dbuser dbpass);
+ $options{authors} = CPAN::Testers::WWW::Reports::Mailer::DBUtils->new(%opts);
+
+ die "Cannot configure CPANSTATS database\n" unless($options{cpanstats});
+ die "Cannot configure AUTHORS database\n" unless($options{authors});
+
+ $options{pause} = download_mailrc();
+
+ # set up API to Template Toolkit
+ $options{tt} = Template->new(
+ {
+ # POST_CHOMP => 1,
+ # PRE_CHOMP => 1,
+ # TRIM => 1,
+ EVAL_PERL => 1,
+ INCLUDE_PATH => [ 'templates' ],
+ }
+ );
+}
+
+sub _help {
+ my $full = shift;
+
+ if($full) {
+ print <<HERE;
+
+Usage: $0 \\
+ [-config=<file>] [-h] [-V]
+
+ --config=<file> database configuration file
+ -h this help screen
+ -V program version
+
+HERE
+
+ }
+
+ print "$0 v$VERSION\n";
+ exit(0);
+}
+
+sub emaildate {
+ my $fmt = 'DABV, DD MABV YYYY hh:mm:ss TZ';
+ my ($second,$minute,$hour,$day,$mon,$year,$dotw) = localtime(time());
+ $year += 1900;
+
+ # create date mini strings
+ my $fmonth = sprintf "%s", $months[$mon]->{value};
+ my $fday = sprintf "%02d", $day;
+ my $fyear = sprintf "%04d", $year;
+ my $fdotw = sprintf "%s", (defined $dotw ? $dotw[$dotw] : 'Sunday');
+ my $amonth = substr($fmonth,0,3);
+ my $adotw = substr($fdotw,0,3);
+ my $fhour = sprintf "%02d", $hour;
+ my $fminute = sprintf "%02d", $minute;
+ my $fsecond = sprintf "%02d", $second;
+
+ # transpose format string into a date string
+ $fmt =~ s/hh/$fhour/;
+ $fmt =~ s/mm/$fminute/;
+ $fmt =~ s/ss/$fsecond/;
+ $fmt =~ s/MABV/$amonth/;
+ $fmt =~ s/DABV/$adotw/;
+ $fmt =~ s/YYYY/$fyear/;
+ $fmt =~ s/DD/$fday/;
+ $fmt =~ s/TZ/UTC/;
+
+ return $fmt;
+}
+
+sub download_mailrc {
+ my $data;
+
+ if(-f 'data/01mailrc.txt') {
+ $data = read_file('data/01mailrc.txt');
+
+ } else {
+ my $url = 'http://www.cpan.org/authors/01mailrc.txt.gz';
+ my $ua = LWP::UserAgent->new;
+ $ua->timeout(180);
+ my $response = $ua->get($url);
+
+ if ($response->is_success) {
+ my $gzipped = $response->content;
+ $data = Compress::Zlib::memGunzip($gzipped);
+ die "Error uncompressing data from $url" unless $data;
+ } else {
+ die "Error fetching $url";
+ }
+ }
+
+ my $p = Parse::CPAN::Authors->new($data);
+ die "Cannot parse data from 01mailrc.txt" unless($p);
+ return $p;
+}
+
+__END__
+
+=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 bug reports and patches to the RT Queue (see below).
+
+Fixes are dependant upon their severity and my availablity. Should a fix not
+be forthcoming, please feel free to (politely) remind me.
+
+RT Queue -
+http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Testers-WWW-Reports-Mailer
+
+=head1 SEE ALSO
+
+L<CPAN::WWW::Testers::Generator>,
+L<CPAN::WWW::Testers>,
+L<CPAN::Testers::WWW::Statistics>
+
+F<http://www.cpantesters.org/>,
+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) 2008 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
+
11 data/example-settings.ini
@@ -0,0 +1,11 @@
+[CPANSTATS]
+driver=SQLite
+database=../db/cpanstats.db
+
+[AUTHORS]
+driver=mysql
+database=preferences
+dbhost=localhost
+dbuser=username
+dbpass=password
+
55 lib/CPAN/Testers/WWW/Reports/Mailer.pm
@@ -0,0 +1,55 @@
+package CPAN::Testers::WWW::Reports::Mailer;
+
+use warnings;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '0.01';
+
+=head1 NAME
+
+CPAN::Testers::WWW::Reports::Mailer - CPAN Testers Reports Mailer toolset
+
+=head1 SYNOPSIS
+
+ use CPAN::Testers::WWW::Reports::Mailer;
+
+ # TO BE COMPLETED
+
+=head1 DESCRIPTION
+
+CPAN Testers Reports Mailer toolset
+
+=cut
+
+# -------------------------------------
+# Library Modules
+
+# -------------------------------------
+# Variables
+
+# -------------------------------------
+# The Public Interface Subs
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+ CPAN::Testers::WWW::Reports::Mailer
+
+=head1 AUTHOR
+
+Barbie, <barbie@missbarbell.co.uk> for
+Miss Barbell Productions, L<http://www.missbarbell.co.uk/>
+
+=head1 COPYRIGHT & LICENSE
+
+ Copyright (C) 2008 Barbie for Miss Barbell Productions
+ All Rights Reserved.
+
+ This module is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+=cut
438 lib/CPAN/Testers/WWW/Reports/Mailer/DBUtils.pm
@@ -0,0 +1,438 @@
+package CPAN::Testers::WWW::Reports::Mailer::DBUtils;
+
+use warnings;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '0.01';
+
+=head1 NAME
+
+CPAN::Testers::WWW::Reports::Mailer::DBUtils - Database Wrapper
+
+=head1 SYNOPSIS
+
+ use CPAN::Testers::WWW::Reports::Mailer::DBUtils;
+
+ my $dbi = CPAN::Testers::WWW::Reports::Mailer::DBUtils->new({
+ driver => 'CSV',
+ file => '/var/www/mysite/db);
+ sub errors { print STDERR "Error: $_[0], sql=$_[1]\n" }
+
+ my @arr = $dbi->GetQuery('array',$sql);
+ my @arr = $dbi->GetQuery('array',$sql,$bid);
+ my @arr = $dbi->GetQuery('hash',$sql,$bid);
+
+ my $id = $dbi->IDQuery($sql,$id,$name);
+ $dbi->DoQuery($sql,$id);
+
+ my $next = Iterator('array',$sql);
+ my @row = &$next;
+
+ my $next = Iterator('hash',$sql);
+ my %row = &$next;
+
+ $value = $dbi->Quote($value);
+
+=head1 DESCRIPTION
+
+The DBUtils package is a further database interface layer, providing a
+collection of control methods to initiate the database connection, handle
+errors and a smooth handover from the program to the database drivers.
+
+=cut
+
+# -------------------------------------
+# Library Modules
+
+use Carp;
+use DBI;
+
+use base qw(Class::Accessor::Fast);
+
+# -------------------------------------
+# Variables
+
+# -------------------------------------
+# The Public Interface Subs
+
+=head2 CONSTRUCTOR
+
+=over 4
+
+=item new({})
+
+The Constructor method. Can be called with an anonymous hash,
+listing the values to be used to connect to and handle the database.
+
+Values in the hash can be
+
+ driver (*)
+ database (+)
+ dbfile (+)
+ dbhost
+ dbport
+ dbuser
+ dbpass
+
+(*) These entries MUST exist in the hash.
+(+) At least ONE of these must exist in the hash, and depend upon the driver.
+
+Note that 'file' is for use with a flat file database, such as DBD::CSV.
+
+=back
+
+=cut
+
+sub new {
+ my ($self, %hash) = @_;
+
+ # check we've got our mandatory fields
+ croak("$self needs a driver!") unless($hash{driver});
+ croak("$self needs a database/file!")
+ unless($hash{database} || $hash{dbfile});
+
+ # create an attributes hash
+ my $dbv = {
+ 'driver' => $hash{driver},
+ 'database' => $hash{database},
+ 'dbfile' => $hash{dbfile},
+ 'dbhost' => $hash{dbhost},
+ 'dbport' => $hash{dbport},
+ 'dbuser' => $hash{dbuser},
+ 'dbpass' => $hash{dbpass},
+ };
+
+ # create the object
+ bless $dbv, $self;
+ return $dbv;
+}
+
+=head2 PUBLIC INTERFACE METHODS
+
+=over 4
+
+=item GetQuery(type,sql,<list>)
+
+ type - 'array' or 'hash'
+ sql - SQL statement
+ <list> - optional additional values to be inserted into SQL placeholders
+
+The function performs a SELECT statement, which returns either a list of lists,
+or a list of hashes. The difference being that for each record, the field
+values are listed in the order they are returned, or via the table column
+name in a hash.
+
+=cut
+
+sub GetQuery {
+ my ($dbv,$type,$sql,@args) = @_;
+ return () unless($sql);
+
+ # if the object doesnt contain a reference to a dbh object
+ # then we need to connect to the database
+ $dbv = &_db_connect($dbv) if not $dbv->{dbh};
+
+ # prepare the sql statement for executing
+ my $sth = $dbv->{dbh}->prepare($sql);
+ unless($sth) {
+ croak("err=".$dbv->{dbh}->errstr.", sql=[$sql], args[".join(",",map{$_ || ''} @args)."]");
+ return ();
+ }
+
+ # execute the SQL using any values sent to the function
+ # to be placed in the sql
+ if(!$sth->execute(@args)) {
+ croak("err=".$sth->errstr.", sql=[$sql], args[".join(",",map{$_ || ''} @args)."]");
+ return ();
+ }
+
+ my @result;
+ # grab the data in the right way
+ if ( $type eq 'array' ) {
+ while ( my $row = $sth->fetchrow_arrayref() ) {
+ push @result, [@{$row}];
+ }
+ } else {
+ while ( my $row = $sth->fetchrow_hashref() ) {
+ push @result, $row;
+ }
+ }
+
+ # finish with our statement handle
+ $sth->finish;
+ # return the found datastructure
+ return @result;
+}
+
+=item Iterator(type,sql,<list>)
+
+ type - 'array' or 'hash'
+ sql - SQL statement
+ <list> - optional additional values to be inserted into SQL placeholders
+
+The function performs a SELECT statement, which returns a subroutine reference
+which can then be used to obtain either a list of lists, or a list of hashes.
+The difference being that for each record, the field values are listed in the
+order they are returned, or via the table column name in a hash.
+
+=cut
+
+sub Iterator {
+ my ($dbv,$type,$sql,@args) = @_;
+ return undef unless($sql);
+
+ # if the object doesnt contain a reference to a dbh object
+ # then we need to connect to the database
+ $dbv = &_db_connect($dbv) if not $dbv->{dbh};
+
+ # prepare the sql statement for executing
+ my $sth = $dbv->{dbh}->prepare($sql);
+ unless($sth) {
+ croak("err=".$dbv->{dbh}->errstr.", sql=[$sql], args[".join(",",map{$_ || ''} @args)."]");
+ return undef;
+ }
+
+ # execute the SQL using any values sent to the function
+ # to be placed in the sql
+ if(!$sth->execute(@args)) {
+ croak("err=".$sth->errstr.", sql=[$sql], args[".join(",",map{$_ || ''} @args)."]");
+ return undef;
+ }
+
+ # grab the data in the right way
+ if ( $type eq 'array' ) {
+ return sub {
+ if ( my $row = $sth->fetchrow_arrayref() ) { return @{$row}; }
+ else { $sth->finish; return; }
+ }
+ } else {
+ return sub {
+ if ( my $row = $sth->fetchrow_hashref() ) { return %$row; }
+ else { $sth->finish; return; }
+ }
+ }
+}
+
+=item DoQuery(sql,<list>)
+
+ sql - SQL statement
+ <list> - optional additional values to be inserted into SQL placeholders
+
+The function performs an SQL statement. If performing an INSERT statement that
+returns an record id, this is returned to the calling function.
+
+=cut
+
+sub DoQuery {
+ my ($dbv,$sql,@args) = @_;
+ $dbv->_doQuery($sql,0,@args);
+}
+
+=item IDQuery(sql,<list>)
+
+ sql - SQL statement
+ <list> - optional additional values to be inserted into SQL placeholders
+
+The function performs an SQL statement. If performing an INSERT statement that
+returns an record id, this is returned to the calling function.
+
+=cut
+
+sub IDQuery {
+ my ($dbv,$sql,@args) = @_;
+ return $dbv->_doQuery($sql,1,@args);
+}
+
+=item DoSQL(sql,<list>)
+
+ sql - SQL statement
+ <list> - optional additional values to be inserted into SQL placeholders
+
+=cut
+
+sub DoSQL {
+ my ($dbv,$sql,@args) = @_;
+ $dbv->_doQuery($sql,0,@args);
+}
+
+# _doQuery(key,idrequired,<list>)
+#
+# key - hash key to sql in phrasebook
+# idrequired - true if an ID value is required on return
+# <list> - optional additional values to be inserted into SQL placeholders
+#
+#The function performs an SQL statement. If performing an INSERT statement that
+#returns an record id, this is returned to the calling function.
+#
+#The first entry in <list> can be an anonymous hash, containing the placeholder
+#values to be interpolated by Class::Phrasebook.
+#
+#Note that if the key is not found in the phrasebook, the function returns
+#with undef.
+#
+
+sub _doQuery {
+ my ($dbv,$sql,$idrequired,@args) = @_;
+ my $rowid = undef;
+
+ return $rowid unless($sql);
+
+ # if the object doesnt contain a refrence to a dbh object
+ # then we need to connect to the database
+ $dbv = &_db_connect($dbv) if not $dbv->{dbh};
+
+ if($idrequired) {
+ # prepare the sql statement for executing
+ my $sth = $dbv->{dbh}->prepare($sql);
+ unless($sth) {
+ croak("err=".$dbv->{dbh}->errstr.", sql=[$sql], args[".join(",",map{$_ || ''} @args)."]");
+ return undef;
+ }
+
+ # execute the SQL using any values sent to the function
+ # to be placed in the sql
+ if(!$sth->execute(@args)) {
+ croak("err=".$sth->errstr.", sql=[$sql], args[".join(",",map{$_ || ''} @args)."]");
+ return undef;
+ }
+
+ if($dbv->{driver} =~ /mysql/i) {
+ $rowid = $dbv->{dbh}->{mysql_insertid};
+ } else {
+ my $row;
+ $rowid = $row->[0] if( $row = $sth->fetchrow_arrayref() );
+ }
+
+ } else {
+ eval { $dbv->{dbh}->do($sql, undef, @args) };
+ if ( $@ ) {
+ croak("err=".$dbv->{dbh}->errstr.", sql=[$sql], args[".join(",",map{$_ || ''} @args)."]");
+ return -1;
+ }
+
+ $rowid = 1; # technically this should be the number of succesful rows
+ }
+
+
+ ## Return the rowid we just used
+ return $rowid;
+}
+
+=item Quote(string)
+
+ string - string to be quoted
+
+The function performs a DBI quote operation, which will quote a string
+according to the SQL rules.
+
+=cut
+
+sub Quote {
+ my $dbv = shift;
+ return undef unless($_[0]);
+
+ # Cant quote with DBD::CSV
+ return $_[0] if($dbv->{driver} =~ /csv/i);
+
+ # if the object doesnt contain a refrence to a dbh object
+ # then we need to connect to the database
+ $dbv = &_db_connect($dbv) if not $dbv->{dbh};
+
+ $dbv->{dbh}->quote($_[0]);
+}
+
+# -------------------------------------
+# The Get & Set Methods Interface Subs
+
+=item Get & Set Methods
+
+The following accessor methods are available:
+
+ driver
+ database
+ dbfile
+ dbhost
+ dbport
+ dbuser
+ dbpass
+
+All functions can be called to return the current value of the associated
+object variable, or be called with a parameter to set a new value for the
+object variable.
+
+(*) Setting these methods will take action immediately. All other access
+methods require a new object to be created, before they can be used.
+
+Examples:
+
+ my $database = $dbi->database();
+ $dbi->database('another');
+
+=cut
+
+__PACKAGE__->mk_accessors(qw(driver database dbfile dbhost dbport dbuser dbpass));
+
+# -------------------------------------
+# The Private Subs
+# These modules should not have to be called from outside this module
+
+sub _db_connect {
+ my $dbv = shift;
+
+ my $dsn = 'dbi:' . $dbv->{driver};
+
+ if($dbv->{driver} =~ /ODBC/) {
+ # all the info is in the Data Source repository
+
+ } elsif($dbv->{driver} =~ /SQLite/) {
+ $dsn .= ':dbname=' . $dbv->{database} if $dbv->{database};
+ $dsn .= ';host=' . $dbv->{dbhost} if $dbv->{dbhost};
+ $dsn .= ';port=' . $dbv->{dbport} if $dbv->{dbport};
+
+ } else {
+ $dsn .= ':f_dir=' . $dbv->{dbfile} if $dbv->{dbfile};
+ $dsn .= ':database=' . $dbv->{database} if $dbv->{database};
+ $dsn .= ';host=' . $dbv->{dbhost} if $dbv->{dbhost};
+ $dsn .= ';port=' . $dbv->{dbport} if $dbv->{dbport};
+ }
+
+ eval {
+ $dbv->{dbh} = DBI->connect($dsn, $dbv->{dbuser}, $dbv->{dbpass},
+ { RaiseError => 1, AutoCommit => 1 });
+ };
+
+ croak("Cannot connect to DB [$dsn]: $@") if($@);
+ return $dbv;
+}
+
+sub DESTROY {
+ my $dbv = shift;
+# $dbv->{dbh}->commit if defined $dbv->{dbh};
+ $dbv->{dbh}->disconnect if defined $dbv->{dbh};
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 SEE ALSO
+
+ DBI,
+
+=head1 AUTHOR
+
+Barbie, <barbie@missbarbell.co.uk> for
+Miss Barbell Productions, L<http://www.missbarbell.co.uk/>
+
+=head1 COPYRIGHT & LICENSE
+
+ Copyright (C) 2002-2008 Barbie for Miss Barbell Productions
+ All Rights Reserved.
+
+ This module is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+=cut
9 t/01base.t
@@ -0,0 +1,9 @@
+#!/usr/bin/perl -w
+use strict;
+
+use Test::More tests => 2;
+
+BEGIN {
+ use_ok( 'CPAN::Testers::WWW::Reports::Mailer' );
+ use_ok( 'CPAN::Testers::WWW::Reports::Mailer::DBUtils' );
+}
10 t/90podtest.t
@@ -0,0 +1,10 @@
+use Test::More;
+
+# Skip if doing a regular install
+plan skip_all => "Author tests not required for installation"
+ unless ( $ENV{AUTOMATED_TESTING} );
+
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+
9 t/91podcover.t
@@ -0,0 +1,9 @@
+use Test::More;
+
+# Skip if doing a regular install
+plan skip_all => "Author tests not required for installation"
+ unless ( $ENV{AUTOMATED_TESTING} );
+
+eval "use Test::Pod::Coverage 0.08";
+plan skip_all => "Test::Pod::Coverage 0.08 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
11 t/94metatest.t
@@ -0,0 +1,11 @@
+use Test::More;
+
+# Skip if doing a regular install
+plan skip_all => "Author tests not required for installation"
+ unless ( $ENV{AUTOMATED_TESTING} );
+
+eval "use Test::CPAN::Meta 0.12";
+plan skip_all => "Test::CPAN::Meta 0.12 required for testing META.yml" if $@;
+meta_yaml_ok();
+
+
29 templates/mailer.eml
@@ -0,0 +1,29 @@
+Dear NAME,
+
+Please find below the latest reports for your distributions, generated by CPAN Testers, from the last 24 hours.
+
+Currently only FAIL reports are listed, with only the first instance of a report for a distribution on a particular platform, using a specific version of Perl. As such you may find further similar reports at http://www.cpantesters.org.
+
+[% FOREACH dist = dists %]
+[% FOREACH vers = dist.versions -%]
+[% dist.dist %]-[% vers.version -%]:
+[% FOREACH arch = vers.platforms -%]
+[% FOREACH pver = arch.perls -%]
+- [% arch.platform %] / [% pver.perl %]:
+[% FOREACH stat = pver.states -%]
+[% FOREACH id = stat.ids -%]
+ - [% stat.state %] http://nntp.x.perl.org/group/perl.cpan.testers/[% id %]
+[% END -%]
+[% END -%]
+[% END -%]
+[% END -%]
+[% END -%]
+
+[% END -%]
+
+This mail is generated by an automated system. If you do not wish to receive these mails, please contact Barbie <barbie@cpan.org> and request to be removed from the automatic mailings. If you have an issue with a particular report, or wish to gain further information from the tester, please use the 'Find A Tester' tool at http://stats.cpantesters.org/cpanmail.html, using the NNTP ID of the report to locate the correct email address.
+
+Thanks,
+The CPAN Testers
+--
+Reports: http::/www.cpantesters.org
18 templates/notification.eml
@@ -0,0 +1,18 @@
+Dear NAME,
+
+Welcome to possibly your first exposure to the CPAN related community that is CPAN Testers. CPAN Testers are a group of helpful volunteers who automatically download and test distributions as they uploaded to the CPAN. You are receiving this mail because we've just started to test what appears to be your first ever CPAN distribution, congratulations and thanks for contributing to CPAN.
+
+But what does this mean to you? Well hopefully you'll discover the benefits of CPAN Testers as we are able to test your distributions on a variety of platforms, using several different Perl versions, and in a selection of different environments. This all helps to feedback to you as an author any bugs that your users may experience with your distributions, before they have the opportunity of downloading and discovering problems for themselves. The feedback also helps users of your distributions to know what versions of your distributions may or may not work in their environment.
+
+CPAN Testers has been running for over 10 years, and with its increased success, and with more and more volunteers adding to the distributed network, it can mean that this feedback can be overwhelming. As such we are in the process of implementing a preferences system for those authors that wish to fine tune the mails they receive. Until the system goes live, this feedback mechanism will be opt-out. If you do not wish to receive further mails, please contact Barbie <barbie@cpan.org> and request to be removed from the automatic mailings. However, these mailing will occur at most once a day, and will collate a list of all the reports for your distributions (current default is FAIL only), that have been generated by the distributed smoke bots over the last 24 hours, which you can then read via the perl.org NNTP server.
+
+If you choose to not receive these mails, you may still find a list of reports for all your distributions on the CPAN Testers Reports website - http://www.cpantesters.org. The site also includes an RSS feed that is dedicated to your most recent reports, which you can add to your chosen feed reader at http://www.cpantesters.org/author/[% author %].rss.
+
+Once you review your reports, if you have an issue with a particular report, or wish to gain further information from the tester, please use the 'Find A Tester' tool at http://stats.cpantesters.org/cpanmail.html, using the NNTP ID of the report to locate the tester's correct email address.
+
+If you wish to find out more about CPAN Testers, please check out our Wiki - http://wiki.cpantesters.org.
+
+Thanks,
+The CPAN Testers
+--
+Reports: http::/www.cpantesters.org
Please sign in to comment.
Something went wrong with that request. Please try again.