Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Notable changes to support files

  • Loading branch information...
commit 92e593751cbec393832b9a36a485d3219ec49e74 1 parent e507a5e
barbie authored
View
10 CHANGES
@@ -1,4 +1,14 @@
Revision history for Perl module CPAN::Testers::WWW::Reports::Mailer.
+0.02 06/11/2008
+ - prefs_distributions table extended to include distribution version,
+ platform, perl version and patches preferences.
+ - code added to cpanstats-mailer (v0.02) to include new preferences.
+ - designed tables so that login and activity are held in the author
+ table, and all distribution preferences are held in the distribution
+ table, where defaults are where distribution == '-'.
+ - redsigned new author insertions
+ - implemented a simple phrasebook lookup for SQL queries.
+
0.01 08/09/2008
- initial release
View
4 MANIFEST
@@ -1,6 +1,6 @@
-bin/cpanstats-mailer
+bin/cpanreps-mailer
CHANGES
-data/example-settings.ini
+data/settings-example.ini
lib/CPAN/Testers/WWW/Reports/Mailer.pm
lib/CPAN/Testers/WWW/Reports/Mailer/DBUtils.pm
Makefile.PL
View
48 META.yml
@@ -1,7 +1,7 @@
--- #YAML:1.0
name: CPAN-Testers-WWW-Reports-Mailer
-version: 0.26
-abstract: CPAN Testers Reports Mailer toolset
+version: 0.02
+abstract: CPAN Testers Reports Mailer
author:
- Barbie <barbie@cpan.org>
@@ -10,44 +10,30 @@ distribution_type: module
installdirs: site
requires:
- Cwd: 0
- CPAN::DistnameInfo: 0
+ Compress::Zlib: 0
+ Config::IniFiles: 0
+ File::Basename: 0
+ File::Slurp: 0
+ Getopt::ArgvFile: 0
+ Getopt::Long: 0
+ LWP::UserAgent: 0
+ Path::Class: 0
+ Parse::CPAN::Authors: 0
+ Template: 0
+ WWW::Mechanize: 0
+ Carp: 0
Class::Accessor::Fast: 0
+ DBD::mysql: 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
+ version: 0.02
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
+ version: 0.02
meta-spec:
version: 1.4
View
29 Makefile.PL
@@ -3,26 +3,33 @@ 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
+ 'Compress::Zlib' => 0,
+ 'Config::IniFiles' => 0,
+ 'File::Basename' => 0,
+ 'File::Slurp' => 0,
+ 'Getopt::ArgvFile' => 0,
+ 'Getopt::Long' => 0,
+ 'LWP::UserAgent' => 0,
+ 'Path::Class' => 0,
+ 'Parse::CPAN::Authors' => 0,
+ 'Template' => 0,
+ 'WWW::Mechanize' => 0,
+
+ 'Carp' => 0,
'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' ],
+ 'EXE_FILES' => [ 'bin/cpanreps-mailer' ],
+
NO_META => 1,
($] >= 5.005 ? ## Add these new keywords supported since 5.005
- (ABSTRACT => 'CPAN Testers Reports Mailer toolset',
+ (ABSTRACT => 'CPAN Testers Reports Mailer',
AUTHOR => 'Barbie <barbie@cpan.org>') : ()),
);
View
490 bin/cpanreps-mailer
@@ -0,0 +1,490 @@
+#!/usr/bin/perl
+use strict;
+$|++;
+
+my $VERSION = '0.02';
+
+#----------------------------------------------------------------------------
+
+=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 Time::Piece;
+use WWW::Mechanize;
+
+use CPAN::Testers::WWW::Reports::Mailer::DBUtils;
+
+# -------------------------------------
+# Variables
+
+my $DEBUG = 1;
+
+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" },
+);
+
+my %phrasebook = (
+ 'GetReports' => "SELECT id,dist,version,platform,perl,state FROM cpanstats WHERE id > $last_id AND state IN ('pass','fail','na','unknown') ORDER BY id",
+ 'GetReportCount' => "SELECT id FROM cpanstats WHERE platform=? AND perl=? AND state=? AND id < ? LIMIT 2",
+ 'GetLatestDistVers' => "SELECT version FROM cpanstats WHERE distribution=? AND AND state='cpan' ORDER BY id DESC LIMIT 1",
+ 'GetAuthor' => "SELECT tester FROM cpanstats WHERE dist=? AND version=? AND state='cpan' LIMIT 1",
+ 'GetDistPrefs' => "SELECT * FROM prefs_distributions WHERE pauseid=? AND distribution=?",
+ 'GetDefaultPrefs' => "SELECT * FROM prefs_authors WHERE pauseid=?",
+ 'InsertAuthorLogin' => 'INSERT INTO prefs_authors (active,lastlogin,pauseid) VALUES (1,?,?)',
+ 'InsertDistPrefs' => "INSERT INTO prefs_authors (pauseid,dist,grade,tuple,version,patches,perl,platform) VALUES (?,?,'FAIL','FIRST','LATEST',0,'ALL','ALL')",
+);
+
+# -------------------------------------
+# 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',$phrasebook{'GetReports'});
+ 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->{grades}{'NONE'});
+ next unless($prefs->{grades}{$row->[5]});
+
+ # check whether only first instance required
+ if($prefs->{tuple} eq 'FIRST') {
+ my @count = $options{cpanstats}->GetQuery('array',$phrasebook{'GetReportCount'}, $row->[3], $row->[4], $row->[5], $row->[0]);
+ next if(@count > 1);
+ }
+
+ # Check whether distribution version is required.
+ # If version set to 'LATEST' check this is the current version, if set
+ # to 'ALL' then we should allow EVERYTHING through, otherwise filter
+ # on the requested versions.
+
+ if($prefs->{version} && $prefs->{version} ne 'ALL') {
+ if($prefs->{version} eq 'LATEST') {
+ my @vers = $options{cpanstats}->GetQuery('array',$phrasebook{'GetLatestDistVers'});
+ next unless($vers[0]->[0] eq $row->[2]);
+ } else {
+ $prefs->{version} =~ s/\s*//g;
+ my %m = map {$_ => 1} split(',',$prefs->{version});
+ next unless($m{$row->[2]});
+ }
+ }
+
+ # Check whether this platform is required.
+ if($prefs->{platform} && $prefs->{platform} ne 'ALL') {
+ $prefs->{platform} =~ s/\s*//g;
+ $prefs->{platform} =~ s/,/|/g;
+ $prefs->{platform} =~ s/\./\\./g;
+ next unless($row->[3] =~ /$prefs->{platform}/);
+ }
+
+ # Check whether this perl version is required.
+ if($prefs->{perl} && $prefs->{perl} ne 'ALL') {
+ $prefs->{perl} =~ s/\s*//g;
+ $prefs->{perl} =~ s/,/|/g;
+ $prefs->{perl} =~ s/\./\\./g;
+ my $v = version->new("$row->[4]")->numify;
+ next if($row->[4] !~ $prefs->{perl} && $v !~ $prefs->{perl});
+ }
+
+ # Check whether patches are required.
+ next if(!$prefs->{patches} && $row->[4] =~ /patch/) {
+
+ 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 ? $pause->name : $author;
+ $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 requested summary report
+
+ if(!$prefs->{active} || $prefs->{active} == 0) {
+ $tvars{subject} = 'Welcome to CPAN Testers';
+ write_mail('notification.eml',\%tvars);
+ $options{authors}->DoQuery($phrasebook{'InsertAuthorLogin'}, time(), $author);
+ $options{authors}->DoQuery($phrasebook{'InsertDistPrefs'}, $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',$phrasebook{'GetAuthor'}, $dist, $vers);
+ $authors{$dist}{$vers} = @author ? $author[0]->[0] : undef;
+ }
+ 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',$phrasebook{'GetDistPrefs'}, $author,$dist);
+ if(@rows) {
+ $prefs{$author}{dists}{$dist} = parse_prefs($rows[0]);
+ 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',$phrasebook{'GetDefaultPrefs'}, $author);
+ if(@rows) {
+ $prefs{$author}{default} = parse_prefs($rows[0]);
+ $prefs{$author}{default}{active} = $rows[0]->{active} || 0;
+ return $prefs{$author}{default};
+ }
+
+ # fall through and assume new author
+ }
+
+ # use global defaults
+ my %prefs = (
+ active => 0,
+ grades => {'FAIL' => 1},
+ tuple => 'FIRST',
+ version => 'LATEST',
+ patches => 0,
+ perl => 'ALL',
+ platform => 'ALL',
+ );
+ return \%prefs;
+}
+
+sub parse_prefs {
+ my $row = shift;
+ my %hash;
+
+ $row->{grade} ||= 'FAIL';
+ my %grades = map {$_ => 1} split(',',$row->{grade});
+
+ $hash{grades} = \%grades;
+ $hash{tuple} = $row->{tuple} || 'FIRST';
+ $hash{version} = $row->{version} || 'LATEST';
+ $hash{patches} = $row->{patches} || 0;
+ $hash{perl} = $row->{perl} || 'ALL';
+ $hash{platform} = $row->{platform} || 'ALL';
+
+ return \%hash;
+}
+
+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;
+
+ if($DEBUG) {
+ 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 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 $t = localtime;
+ return $t->strftime("%a, %d %b %Y %H:%M:%S %z");
+}
+
+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
+
View
6 data/example-settings.ini → data/settings-example.ini
@@ -2,10 +2,12 @@
driver=SQLite
database=../db/cpanstats.db
-[AUTHORS]
+[CPANPREFS]
driver=mysql
-database=preferences
+database=cpanprefs
dbhost=localhost
dbuser=username
dbpass=password
+[SETTINGS]
+DEBUG=1
View
24 lib/CPAN/Testers/WWW/Reports/Mailer.pm
@@ -4,11 +4,11 @@ use warnings;
use strict;
use vars qw($VERSION);
-$VERSION = '0.01';
+$VERSION = '0.02';
=head1 NAME
-CPAN::Testers::WWW::Reports::Mailer - CPAN Testers Reports Mailer toolset
+CPAN::Testers::WWW::Reports::Mailer - CPAN Testers Reports Mailer
=head1 SYNOPSIS
@@ -18,7 +18,17 @@ CPAN::Testers::WWW::Reports::Mailer - CPAN Testers Reports Mailer toolset
=head1 DESCRIPTION
-CPAN Testers Reports Mailer toolset
+The CPAN Testers Reports Mailer takes the preferences set within the CPANPREFS
+database, and uses them to filter out reports that the author does or does not
+wish to be made aware of.
+
+New authors are added to the system as a report for their first reported
+distribution is submitted by a tester. Default settings are applied in the
+first instance, with the author able to update these via the preferences
+website.
+
+Initially only a Daily Summary Report is available, in time a Weekly Summary
+Report and the individual reports will also be available.
=cut
@@ -37,7 +47,13 @@ __END__
=head1 SEE ALSO
- CPAN::Testers::WWW::Reports::Mailer
+L<CPAN::WWW::Testers::Generator>
+L<CPAN::WWW::Testers>
+L<CPAN::Testers::WWW::Statistics>
+
+F<http://www.cpantesters.org/>,
+F<http://stats.cpantesters.org/>,
+F<http://wiki.cpantesters.org/>
=head1 AUTHOR
View
47 lib/CPAN/Testers/WWW/Reports/Mailer/DBUtils.pm
@@ -4,7 +4,7 @@ use warnings;
use strict;
use vars qw($VERSION);
-$VERSION = '0.01';
+$VERSION = '0.02';
=head1 NAME
@@ -94,13 +94,14 @@ sub new {
# 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},
+ 'driver' => $hash{driver},
+ 'database' => $hash{database},
+ 'dbfile' => $hash{dbfile},
+ 'dbhost' => $hash{dbhost},
+ 'dbport' => $hash{dbport},
+ 'dbuser' => $hash{dbuser},
+ 'dbpass' => $hash{dbpass},
+ 'AutoCommit' => defined $hash{AutoCommit} ? $hash{AutoCommit} : 1,
};
# create the object
@@ -256,21 +257,14 @@ sub DoSQL {
$dbv->_doQuery($sql,0,@args);
}
-# _doQuery(key,idrequired,<list>)
+# _doQuery(sql,idrequired,<list>)
#
-# key - hash key to sql in phrasebook
+# sql - SQL statement
# 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) = @_;
@@ -381,15 +375,21 @@ sub _db_connect {
my $dbv = shift;
my $dsn = 'dbi:' . $dbv->{driver};
+ my %options = (
+ RaiseError => 1,
+ AutoCommit => $dbv->{AutoCommit},
+ );
if($dbv->{driver} =~ /ODBC/) {
# all the info is in the Data Source repository
- } elsif($dbv->{driver} =~ /SQLite/) {
+ } elsif($dbv->{driver} =~ /SQLite/i) {
$dsn .= ':dbname=' . $dbv->{database} if $dbv->{database};
$dsn .= ';host=' . $dbv->{dbhost} if $dbv->{dbhost};
$dsn .= ';port=' . $dbv->{dbport} if $dbv->{dbport};
+ $options{sqlite_handle_binary_nulls} = 1;
+
} else {
$dsn .= ':f_dir=' . $dbv->{dbfile} if $dbv->{dbfile};
$dsn .= ':database=' . $dbv->{database} if $dbv->{database};
@@ -398,8 +398,7 @@ sub _db_connect {
}
eval {
- $dbv->{dbh} = DBI->connect($dsn, $dbv->{dbuser}, $dbv->{dbpass},
- { RaiseError => 1, AutoCommit => 1 });
+ $dbv->{dbh} = DBI->connect($dsn, $dbv->{dbuser}, $dbv->{dbpass}, \%options);
};
croak("Cannot connect to DB [$dsn]: $@") if($@);
@@ -420,7 +419,13 @@ __END__
=head1 SEE ALSO
- DBI,
+L<CPAN::WWW::Testers::Generator>
+L<CPAN::WWW::Testers>
+L<CPAN::Testers::WWW::Statistics>
+
+F<http://www.cpantesters.org/>,
+F<http://stats.cpantesters.org/>,
+F<http://wiki.cpantesters.org/>
=head1 AUTHOR

0 comments on commit 92e5937

Please sign in to comment.
Something went wrong with that request. Please try again.