Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

various updates in preparation for 0.31, see CHANGES

  • Loading branch information...
commit 2522f33ee94bbc15c62c3648c1a8b22ce9b773de 1 parent a01c72a
barbie authored
View
5 CHANGES
@@ -1,5 +1,10 @@
Revision history for Perl module CPAN::WWW::Testers::Generator.
+0.31 current
+ - added epoch to date extraction from article.
+ - added filename reference from CPAN-DistnameInfo.
+ - added ability to provide SQL string in bin/cpanstats-select (v0.09).
+
0.30 01/10/2008
- ensure upload pattern matching is for the end of the string.
- add more option validation in bin/cpanstats-verify (v0.20).
View
8 META.yml
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: CPAN-WWW-Testers-Generator
-version: 0.30
+version: 0.31
abstract: Download and summarize CPAN Testers data
author:
- Barbie <barbie@cpan.org>
@@ -36,13 +36,13 @@ build_requires:
provides:
CPAN::WWW::Testers::Generator:
file: lib/CPAN/WWW/Testers/Generator.pm
- version: 0.30
+ version: 0.31
CPAN::WWW::Testers::Generator::Article:
file: lib/CPAN/WWW/Testers/Generator/Article.pm
- version: 0.30
+ version: 0.31
CPAN::WWW::Testers::Generator::Database:
file: lib/CPAN/WWW/Testers/Generator/Database.pm
- version: 0.30
+ version: 0.31
no_index:
directory:
View
1  Makefile.PL
@@ -16,6 +16,7 @@ WriteMakefile(
'MIME::Base64' => 0,
'MIME::QuotedPrint' => 0,
'Net::NNTP' => 0,
+ 'Time::Local' => 0,
'version' => 0,
'Test::More' => 0, # only for testing
View
59 bin/cpanstats-select
@@ -77,45 +77,56 @@ print STDERR "Cannot connect to database [$options{database}]\n" unless($dbi)
# '(id,state,postdate,tester,dist,version,platform,perl) '.
-my $sql = "SELECT * FROM cpanstats WHERE ";
-my @where;
-
-# only one of the following at a time
-@where = ("dist like '%$options{distro}%'") if(defined $options{distro});
-@where = ("dist='$options{dist}'") if(defined $options{dist});
-@where = ("id=$options{nntp}") if(defined $options{nntp});
-
-push @where, "state='$options{grade}'" if(defined $options{grade});
-push @where, "version='$options{version}'" if(defined $options{version});
-push @where, "version LIKE '%$options{distversion}%'" if(defined $options{distversion});
-push @where, "postdate='$options{date}'" if(defined $options{date});
-push @where, "tester LIKE '%$options{tester}%'" if(defined $options{tester} && $options{tester} ne '-');
-push @where, "tester=''" if(defined $options{tester} && $options{tester} eq '-');
-push @where, "platform like '$options{platform}%'" if(defined $options{platform} && $options{platform} ne '-');
-push @where, "platform=''" if(defined $options{platform} && $options{platform} eq '-');
-push @where, "perl='$options{perl}'" if(defined $options{perl} && $options{perl} ne '-');
-push @where, "perl=''" if(defined $options{perl} && $options{perl} eq '-');
-
-if(@where) {
- my @rows = $dbi->get_query($sql . join(' AND ',@where));
+if($options{sql}) {
+ my @rows = $dbi->get_query($options{sql});
if(@rows) {
for my $row (@rows) {
print join(",",@$row) . "\n";
- }
+ }
} else {
print "Sorry, no results returned\n";
}
} else {
- print "No SQL arguments given\n";
+ my $sql = "SELECT * FROM cpanstats WHERE ";
+ my @where;
+
+ # only one of the following at a time
+ @where = ("dist LIKE '\%$options{distro}\%'") if(defined $options{distro});
+ @where = ("dist='$options{dist}'") if(defined $options{dist});
+ @where = ("id=$options{nntp}") if(defined $options{nntp});
+
+ push @where, "state='$options{grade}'" if(defined $options{grade});
+ push @where, "version='$options{version}'" if(defined $options{version});
+ push @where, "version LIKE '\%$options{distversion}\%'" if(defined $options{distversion});
+ push @where, "postdate='$options{date}'" if(defined $options{date});
+ push @where, "tester LIKE '\%$options{tester}\%'" if(defined $options{tester} && $options{tester} ne '-');
+ push @where, "tester=''" if(defined $options{tester} && $options{tester} eq '-');
+ push @where, "platform LIKE '$options{platform}\%'" if(defined $options{platform} && $options{platform} ne '-');
+ push @where, "platform=''" if(defined $options{platform} && $options{platform} eq '-');
+ push @where, "perl='$options{perl}'" if(defined $options{perl} && $options{perl} ne '-');
+ push @where, "perl=''" if(defined $options{perl} && $options{perl} eq '-');
+
+ if(@where) {
+ my @rows = $dbi->get_query($sql . join(' AND ',@where));
+ if(@rows) {
+ for my $row (@rows) {
+ print join(",",@$row) . "\n";
+ }
+ } else {
+ print "Sorry, no results returned\n";
+ }
+ } else {
+ print "No SQL arguments given\n";
+ }
}
-
# -------------------------------------
# Subroutines
sub init_options {
GetOptions( \%options,
'database=s',
+ 'sql=s',
'nntp|n=s',
'grade|g=s',
'distro|m=s',
View
2  lib/CPAN/WWW/Testers/Generator.pm
@@ -4,7 +4,7 @@ use warnings;
use strict;
use vars qw($VERSION);
-$VERSION = '0.30';
+$VERSION = '0.31';
#----------------------------------------------------------------------------
# Library Modules
View
64 lib/CPAN/WWW/Testers/Generator/Article.pm
@@ -4,15 +4,16 @@ use warnings;
use strict;
use vars qw($VERSION);
-$VERSION = '0.30';
+$VERSION = '0.31';
#----------------------------------------------------------------------------
# Library Modules
-use MIME::Base64;
-use MIME::QuotedPrint;
use CPAN::DistnameInfo;
use Email::Simple;
+use MIME::Base64;
+use MIME::QuotedPrint;
+use Time::Local;
use base qw( Class::Accessor::Fast );
@@ -24,11 +25,25 @@ my %month = (
Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12,
);
+my %regexes = (
+ # with time
+ 1 => { re => qr/(?:\w+,)?\s+(\d+)\s+(\w+)\s+(\d+)\s+(\d+):(\d+)/, f => [qw(day month year hour min)] }, # Wed, 13 September 2004 06:29
+ 2 => { re => qr/(\d+)\s+(\w+)\s+(\d+)\s+(\d+):(\d+)/, f => [qw(day month year hour min)] }, # 13 September 2004 06:29
+ 3 => { re => qr/(\w+)?\s+(\d+),?\s+(\d+)\s+(\d+):(\d+)/, f => [qw(month day year hour min)] }, # September 22, 1999 06:29
+
+ # just the date
+ 4 => { re => qr/(?:\w+,)?\s+(\d+)\s+(\w+)\s+(\d+)/, f => [qw(day month year)] }, # Wed, 13 September 2004
+ 5 => { re => qr/(\d+)\s+(\w+)\s+(\d+)/, f => [qw(day month year)] }, # 13 September 2004
+ 6 => { re => qr/(\w+)?\s+(\d+),?\s+(\d+)/, f => [qw(month day year)] }, # September 22, 1999 06:29
+);
+
+
#----------------------------------------------------------------------------
# The Application Programming Interface
-__PACKAGE__->mk_accessors(qw( postdate date status from distribution version
- perl osname osvers archname subject author));
+__PACKAGE__->mk_accessors(qw(
+ postdate date epoch status from distribution version
+ perl osname osvers archname subject author filename));
sub new {
my($class, $article) = @_;
@@ -50,41 +65,30 @@ sub new {
$self->{from} = $from;
$self->{subject} = $subject;
- ($self->{postdate},$self->{date}) = _parse_date($mail);
+ ($self->{postdate},$self->{date},$self->{epoch}) = _parse_date($mail);
return $self;
}
sub _parse_date {
my $mail = shift;
- my ($date1,$date2) = _extract_date($mail->header("Date"));
+ my ($date1,$date2,$date3) = _extract_date($mail->header("Date"));
my @received = $mail->header("Received");
for my $hdr (@received) {
next unless($hdr =~ /.*;\s+(.*)\s*$/);
- my ($dt1,$dt2) = _extract_date($1);
+ my ($dt1,$dt2,$dt3) = _extract_date($1);
if($dt2 > $date2 + 1200) {
$date1 = $dt1;
$date2 = $dt2;
+ $date3 = $dt3;
}
}
#print STDERR " ... X.[Date: ".($date||'')."]\n";
- return($date1,$date2);
+ return($date1,$date2,$date3);
}
-my %regexes = (
- # with time
- 1 => { re => qr/(?:\w+,)?\s+(\d+)\s+(\w+)\s+(\d+)\s+(\d+):(\d+)/, f => [qw(day month year hour min)] }, # Wed, 13 September 2004 06:29
- 2 => { re => qr/(\d+)\s+(\w+)\s+(\d+)\s+(\d+):(\d+)/, f => [qw(day month year hour min)] }, # 13 September 2004 06:29
- 3 => { re => qr/(\w+)?\s+(\d+),?\s+(\d+)\s+(\d+):(\d+)/, f => [qw(month day year hour min)] }, # September 22, 1999 06:29
-
- # just the date
- 4 => { re => qr/(?:\w+,)?\s+(\d+)\s+(\w+)\s+(\d+)/, f => [qw(day month year)] }, # Wed, 13 September 2004
- 5 => { re => qr/(\d+)\s+(\w+)\s+(\d+)/, f => [qw(day month year)] }, # 13 September 2004
- 6 => { re => qr/(\w+)?\s+(\d+),?\s+(\d+)/, f => [qw(month day year)] }, # September 22, 1999 06:29
-);
-
sub _extract_date {
my $date = shift;
my (%fields,@fields,$index);
@@ -99,20 +103,24 @@ sub _extract_date {
}
}
- return('000000','000000000000') unless(@fields && $index);
+ return('000000','000000000000',0) unless(@fields && $index);
@fields{@{$regexes{$index}->{f}}} = @fields;
$fields{month} = substr($fields{month},0,3);
- return('000000','000000000000') unless($month{$fields{month}} && $fields{year} > 1998);
+ $fields{mon} = $month{$fields{month}};
+ return('000000','000000000000',0) unless($fields{mon} && $fields{year} > 1998);
- $fields{$_} ||= 0 for(qw(year month day hour min));
+ $fields{$_} ||= 0 for(qw(sec min hour day mon year));
+ my @date = map { $fields{$_} } qw(sec min hour day mon year);
#print STDERR "# ... 1.[$_][$fields{$_}]\n" for(qw(year month day hour min));
- my $short = sprintf "%04d%02d", $fields{year}, $month{$fields{month}};
- my $long = sprintf "%04d%02d%02d%02d%02d", $fields{year}, $month{$fields{month}}, $fields{day}, $fields{hour}, $fields{min};
+ my $short = sprintf "%04d%02d", $fields{year}, $fields{mon};
+ my $long = sprintf "%04d%02d%02d%02d%02d", $fields{year}, $fields{mon}, $fields{day}, $fields{hour}, $fields{min};
+ $date[4]--;
+ my $epoch = timelocal(@date);
- return($short,$long);
+ return($short,$long,$epoch);
}
sub parse_upload {
@@ -141,6 +149,7 @@ sub parse_upload {
$self->distribution($d->dist);
$self->version($d->version);
$self->author($d->cpanid);
+ $self->filename($d->filename);
return 1;
}
@@ -185,6 +194,7 @@ sub parse_report {
$self->perl($perl);
$self->osname($osname || "");
$self->osvers($osvers || "");
+ $self->filename($d->filename);
unless($archname || $platform) {
if($osname && $osvers) { $platform = "$osname-$osvers" }
Please sign in to comment.
Something went wrong with that request. Please try again.