Created
March 28, 2011 10:28
-
-
Save wchristian/890253 to your computer and use it in GitHub Desktop.
compare_report_sent.pl
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
use strict; | |
use warnings; | |
package compare_reports; | |
use CPAN::Reporter::History; # _split_history | |
use File::Slurp qw'read_file write_file'; | |
use List::Util 'min'; | |
use CPANDB; | |
use DBIx::Class::Schema::Loader 0.05; | |
use Data::Dumper::Concise; | |
{ | |
package CPANDB::Schema; | |
use base qw/DBIx::Class::Schema::Loader/; | |
__PACKAGE__->loader_options( naming => 'v5', use_moose => 0 ); | |
} | |
# edit these ############################# | |
my $old_file = 'reports-sent.db'; | |
my $new_file = 'new_eumm_reports-sent.db'; | |
my $old_link = "http://dl.dropbox.com/u/10190786/reports/$old_file"; | |
my $new_link = "http://dl.dropbox.com/u/10190786/reports/$new_file"; | |
my $platform = "Windows 7 (ActivePerl)"; | |
my $tester_matrix_os = 'MSWin32'; | |
my %eumms = ( old => { '5.10.1' => '6.55_02', '5.12.2' => '6.56' }, new => { '5.10.1' => '6.57_10', '5.12.2' => '6.57_10' } ); | |
my @perls = ( '5.10.1', '5.12.2' ); | |
########################################## | |
# globals ################################ | |
my $left_to_test = 0; | |
my $dists = prepare_cpandb(); | |
my %dists_by_short_name = get_dists_by_short_name(); | |
my %report_groups_by_dist; | |
my %report_groups_by_dist_wo_v; | |
########################################## | |
run(); | |
exit; | |
sub run { | |
my @reports = ( parse_report_file( $old_file, 'old' ), parse_report_file( $new_file, 'new' ) ); | |
my @report_groups = group_filter_and_sort_reports( \@reports ); | |
%report_groups_by_dist = map { $_->{dist} => $_ } @report_groups; | |
push @{ $report_groups_by_dist_wo_v{ $_->{dist_wo_version} } }, $_ for @report_groups; | |
my $page = make_comparison_page( scalar( @reports ), @report_groups ); | |
write_file 'comparison.html', $page; | |
return; | |
} | |
sub parse_report_file { | |
my ( $file, $eumm ) = @_; | |
my @reports = grep !/^#/, read_file $file; | |
@reports = map CPAN::Reporter::History::_split_history( $_ ), @reports; | |
$_->{eumm} = $eumm for @reports; | |
$reports[$_]->{id} = $_ + 1 for 0 .. $#reports; | |
return @reports; | |
} | |
sub untested { | |
my ( $report_groups, $eumm ) = @_; | |
my @untested = grep { !$_->{$eumm} or !$_->{$eumm}{rep_by_perl}{"5.12.2"} or !$_->{$eumm}{rep_by_perl}{"5.10.1"} } @{$report_groups}; | |
@untested = grep { !$_->{old}{fail} } @untested; | |
my @untested_12 = grep { !$_->{$eumm} or !$_->{$eumm}{rep_by_perl}{"5.12.2"} } @untested; | |
my @untested_10 = grep { !$_->{$eumm} or !$_->{$eumm}{rep_by_perl}{"5.10.1"} } @untested; | |
#$left_to_test += scalar @untested_12 + scalar @untested_10; | |
write_file "untested.12.$eumm", join "\n", map extend_untested( $_ ), @untested_12; | |
write_file "untested.10.$eumm", join "\n", reverse map extend_untested( $_ ), @untested_10; | |
return; | |
} | |
sub failures_to_retest { | |
my ( $report_groups ) = @_; | |
my @retest = grep { $_->{old} and $_->{new} and !$_->{old}{fail} and $_->{new}{fail} } @{$report_groups}; | |
@retest = sort { $a->{id} <=> $b->{id} } @retest; | |
$left_to_test += scalar @retest; | |
write_file "retest", join "\n", map extend_untested( $_ ), @retest; | |
return; | |
} | |
sub group_filter_and_sort_reports { | |
my ( $reports ) = @_; | |
my %reports_by_dist; | |
for ( @{$reports} ) { | |
push @{ $reports_by_dist{ $_->{dist} }{ $_->{eumm} }{reports} }, $_; | |
$reports_by_dist{ $_->{dist} }{ $_->{eumm} }{fail} = 1 if $_->{grade} ne 'PASS'; | |
push @{ $reports_by_dist{ $_->{dist} }{ $_->{eumm} }{rep_by_perl}{ $_->{perl} } }, $_; | |
$reports_by_dist{ $_->{dist} }{dist} = $_->{dist}; | |
$reports_by_dist{ $_->{dist} }{dist_wo_version} = $_->{dist}; | |
$reports_by_dist{ $_->{dist} }{dist_wo_version} =~ s/-v*[\.\d_]+?$//i; | |
} | |
my @report_groups = values %reports_by_dist; | |
$_->{id} = id_for_report_group( $_ ) for @report_groups; | |
untested( \@report_groups, 'old' ); | |
untested( \@report_groups, 'new' ); | |
failures_to_retest( \@report_groups ); | |
@report_groups = grep { $_->{new} } @report_groups; | |
$_->{both_fail} = ( $_->{new}{fail} and $_->{old}{fail} ) || 0 for @report_groups; | |
$_->{one_fails} = ( $_->{new}{fail} or $_->{old}{fail} ) || 0 for @report_groups; | |
@report_groups = grep { $_->{one_fails} } @report_groups; | |
@report_groups = sort { $a->{id} <=> $b->{id} } @report_groups; | |
@report_groups = sort { ( keys %{ $b->{old} } and keys %{ $b->{new} } ) <=> ( keys %{ $a->{old} } and keys %{ $a->{new} } ) } @report_groups; | |
@report_groups = sort { $a->{both_fail} <=> $b->{both_fail} } @report_groups; | |
@report_groups = sort { $b->{one_fails} <=> $a->{one_fails} } @report_groups; | |
return @report_groups; | |
} | |
sub extend_untested { | |
my ( $untested ) = @_; | |
my $dists = $dists_by_short_name{ $untested->{dist_wo_version} }; | |
for my $cand ( @{$dists} ) { | |
next if $cand->{dist_file} !~ /$untested->{dist}/; | |
my $file = $cand->{dist_file}; | |
$file =~ s@^.*?/.*?/@@; | |
return $file; | |
} | |
return; | |
} | |
sub id_for_report_group { | |
my ( $report_group ) = @_; | |
my @id_reports = grep { $_->{grade} ne 'PASS' } @{ $report_group->{new}{reports} }; | |
return 0 if !@id_reports; | |
my @ids = map { $_->{id} } @id_reports; | |
my $id = min( @ids ); | |
return $id || 0; | |
} | |
sub get_fail_deps { | |
my ( $rep ) = @_; | |
my @fail_deps; | |
my @disc_deps; | |
my @deps = deps( $report_groups_by_dist{ $rep->{dist} }->{dist_wo_version} ); | |
for my $dep ( @deps ) { | |
my $dep_groups = $report_groups_by_dist_wo_v{$dep}; | |
for my $dep_group ( @{$dep_groups} ) { | |
my $reports = $dep_group->{ $rep->{eumm} }{rep_by_perl}{ $rep->{perl} }; | |
push @fail_deps, grep { $_->{grade} ne 'PASS' and $_->{grade} ne 'DISCARD' } @{$reports}; | |
push @disc_deps, grep { $_->{grade} eq 'DISCARD' or $_->{grade} eq 'UNKNOWN' } @{$reports}; | |
} | |
} | |
return ( \@fail_deps, \@disc_deps ) if !@disc_deps; | |
while ( @disc_deps ) { | |
my $disc_dep = shift @disc_deps; | |
my ( $fail_deps, $disc_deps ) = get_fail_deps( $disc_dep ); | |
push @fail_deps, @{$fail_deps}; | |
push @disc_deps, @{$disc_deps}; | |
1; | |
} | |
return ( \@fail_deps, \@disc_deps ); | |
} | |
sub discard_reason { | |
my ( $rep ) = @_; | |
return '' if $rep->{grade} ne 'DISCARD' and $rep->{grade} ne 'UNKNOWN'; | |
my ( $fail_deps ) = get_fail_deps( $rep ); | |
$fail_deps = join " ", map { "<a href='#$_->{dist}' alt='$_->{dist}' title='$_->{dist}'>?</a>" } @{$fail_deps}; | |
return '' if !$fail_deps; | |
return " $fail_deps"; | |
} | |
sub make_report_line { | |
my ( $report_group, $index ) = @_; | |
my $class = ''; | |
$class = 'alternate' if $index % 2; | |
my @cells; | |
for my $eumm ( qw( old new ) ) { | |
for my $perl ( 0 .. 1 ) { | |
my @fields; | |
for my $rep ( @{ $report_group->{$eumm}{rep_by_perl}{ $perls[$perl] } } ) { | |
my $field = "$rep->{phase}: <span class='$rep->{grade}'>$rep->{grade}</span>"; | |
#$field .= discard_reason( $rep ); | |
push @fields, $field; | |
} | |
my $field = join '<br>', @fields; | |
push @cells, "<td>$field</td>"; | |
} | |
} | |
my $cells = join "\n", @cells; | |
my $regression_state = regression_state()->{ $report_group->{dist} }; | |
$regression_state = { link => $regression_state } if !ref $regression_state and $regression_state and $regression_state =~ m@://@; | |
$regression_state = { verdict => $regression_state } if !ref $regression_state; | |
$regression_state->{verdict} ||= ''; | |
$regression_state->{verdict} = '✖' if ( $cells =~ /DISCARD/ and $cells !~ /(FAIL|UNKNOWN|NA)/ ) or !$report_group->{new}{fail}; | |
if ( $regression_state->{link} ) { | |
$regression_state->{verdict} ||= 'yes'; | |
$regression_state = "<a href='$regression_state->{link}'>$regression_state->{verdict}</a>"; | |
} | |
else { | |
$regression_state = $regression_state->{verdict}; | |
} | |
my $line = " | |
<tr class='$class'> | |
<td> | |
$report_group->{id} | |
</td> | |
<td> | |
<a name='$report_group->{dist}'></a> | |
<a href='http://search.cpan.org/search?query=$report_group->{dist_wo_version}&mode=dist'>$report_group->{dist}</a> | |
</td> | |
<td style='white-space:nowrap;'> | |
<a href='http://matrix.cpantesters.org/?dist=$report_group->{dist}'>Matrix</a> | |
- | |
<a href='http://matrix.cpantesters.org/?dist=$report_group->{dist};reports=1;os=$tester_matrix_os'>Reports</a> | |
</td> | |
$cells | |
<td> | |
$regression_state | |
</td> | |
</tr> | |
"; | |
return $line; | |
} | |
sub regression_state { | |
my $meta_issue = 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/15'; | |
{ | |
'Data-Properties-YAML-0.02' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/7', | |
'Module-Install-1.00' => { verdict => 'not ours', link => 'https://rt.cpan.org/Ticket/Display.html?id=61464' }, | |
'File-Find-Rule-Perl-1.10' => { verdict => 'not ours', link => 'https://rt.cpan.org/Public/Bug/Display.html?id=67101' }, | |
'accessors-1.01' => 'no', | |
'MooseX-Storage-0.29' => { verdict => 'no', link => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/8' }, | |
'GD-Barcode-Code93-1.4' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/9', | |
'Test-WWW-Selenium-1.24' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/10', | |
'Chemistry-Canonicalize-0.11' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues#issue/7', | |
'Iterator-File-1.01' => 'no', | |
'Rcs-Agent-1.05' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues#issue/7', | |
'Net-SMS-WAY2SMS-0.005' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues#issue/10', | |
'Mail-Thread-2.55' => 'no', | |
'AcePerl-1.92' => 'no', | |
'Plucene-Plugin-FileDocument-1.01' => 'no', | |
'CGI-Application-Plugin-CaptureIO-0.01' => { verdict => 'no', link => 'https://rt.cpan.org/Ticket/Display.html?id=67178&results=c67ff3905c8b69d65cd7e344cace8405' }, | |
'CGI-Mungo-1.3.0' => 'no', | |
'Net-SMS-TxtLocal-0.02' => 'no', | |
'DBIx-MySperqlOO-1.01' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/#issue/7', | |
'FCGI-0.71' => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/11#issue/11', | |
'List-Parseable-1.05' => { verdict => 'no', link => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues#issue/12' }, | |
'Module-Install-ReadmePodFromPod-0.01' => { verdict => 'maybe', link => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues#issue/13' }, | |
'GD-Text-Arc-0.02' => { verdict => 'no', link => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/14' }, | |
'Devel-Comments-v1.1.3' => { verdict => 'no', link => 'http://www.cpantesters.org/cpan/report/12b50e89-6d10-1014-a9d8-8c82000ca92b' }, | |
'WebService-Google-Suggest-0.05' => { verdict => 'no', link => 'http://www.cpantesters.org/cpan/report/81584a68-4ee8-11e0-92d5-3fb5282221a5' }, | |
'MooseX-Compile-0.01' => { verdict => 'no', link => 'https://rt.cpan.org/Ticket/Display.html?id=67309&results=337202b9478ab02d31de5f90113f1522' }, | |
'Set-Toolkit-0.11' => { verdict => 'no', link => 'https://rt.cpan.org/Ticket/Display.html?id=67343&results=0a1cdb65284e2c7d0751e5c751703a0f' }, | |
'Net-FTP-Recursive-2.04' => $meta_issue, | |
'Image-Imgur-0.01' => $meta_issue, | |
'TweetHook-API-0.01' => $meta_issue, | |
'FLAT-0.9.1' => $meta_issue, | |
'Array-Suffix-0.5' => $meta_issue, | |
'WWW-CMS-0.86' => $meta_issue, | |
'Attribute-Signature-1.10' => $meta_issue, | |
'SQL-Library-0.0.3' => $meta_issue, | |
'' => { verdict => '', link => '' }, | |
'' => '', | |
}; | |
} | |
sub make_comparison_page { | |
use Smart::Comments; | |
my ( $reports_total, @report_groups ) = @_; | |
#my @report_group_lines = map make_report_line( $report_groups[$_], $_ ), ; | |
my @report_group_lines; | |
for ( 0 .. $#report_groups ) { ### |===[%] | | |
push @report_group_lines, make_report_line( $report_groups[$_], $_ ); | |
} | |
my $report_group_lines = join "\n", @report_group_lines; | |
my $generation_time = localtime time; | |
return " | |
<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> | |
<html> | |
<head> | |
<style> | |
td, table, th { | |
border-collapse:collapse; | |
border: 1px solid grey; | |
} | |
td { | |
padding: 0.05em 0.5em 0.05em 0.5em; | |
} | |
.DISCARD { | |
color: yellow; | |
} | |
.PASS { | |
color: Lime; | |
} | |
.FAIL { | |
color: red; | |
} | |
.UNKNOWN { | |
color: orange; | |
} | |
body { | |
color: white; | |
background-color: black; | |
} | |
a { | |
color: white; | |
} | |
a:visited { | |
color: grey; | |
} | |
.alternate { | |
background-color: 202020; | |
} | |
</style> | |
</head> | |
<body> | |
<h1>$platform - $generation_time - ( $reports_total reports )</h1> | |
<h2>Left To Test: $left_to_test</h2> | |
<h3><a href='$old_link'>Old Reports DB</a> - <a href='$new_link'>New Reports DB</a></h3> | |
<div style='width=25em;'> | |
Reports link provided just in case. | |
They link to report list of dist on | |
configured OS, but reports may not | |
be processed by CPAN-Testers yet.<br><br> | |
The question marks after DISCARD grades show the failing dependencies of a module in tooltip and also link to it in the list. Some dists do not have those because they are <a href='https://rt.cpan.org/Ticket/Display.html?id=67031'>missing in CPANDB</a>. | |
</div> | |
<br> | |
<div style='width=25em;'> | |
Source code is available here: <a href='https://gist.github.com/890253'>Github Gist 890253</a> | |
</div> | |
<br> | |
<table> | |
<tr> | |
<th rowspan='2' colspan='3'>dist</th> | |
<th>EUMM $eumms{old}{$perls[0]}</th> | |
<th>EUMM $eumms{old}{$perls[1]}</th> | |
<th>EUMM $eumms{new}{$perls[0]}</th> | |
<th>EUMM $eumms{new}{$perls[1]}</th> | |
<th rowspan='2'>Regr.</th> | |
</tr> | |
<tr> | |
<th>$perls[0]</th> | |
<th>$perls[1]</th> | |
<th>$perls[0]</th> | |
<th>$perls[1]</th> | |
</tr> | |
$report_group_lines | |
</table> | |
</body> | |
</html> | |
"; | |
} | |
sub prepare_cpandb { | |
my $s = CPANDB::Schema->connect( sub { CPANDB->dbh } ); | |
my $distsrc = $s->class( 'Distribution' ); | |
my $depsrc = $s->class( 'Dependency' ); | |
$distsrc->has_many( 'req_links', $depsrc, { 'foreign.distribution' => 'self.' . ( $distsrc->primary_columns )[0] }, ); | |
$depsrc->belongs_to( 'dep', $distsrc, { 'foreign.' . ( $distsrc->primary_columns )[0] => 'self.distribution' }, ); | |
$distsrc->has_many( 'dep_links', $depsrc, { 'foreign.dependency' => 'self.' . ( $distsrc->primary_columns )[0] }, ); | |
$depsrc->belongs_to( 'req', $distsrc, { 'foreign.' . ( $distsrc->primary_columns )[0] => 'self.dependency' }, ); | |
for ( qw/Distribution Dependency/ ) { | |
my $class = $s->class( $_ ); | |
$s->unregister_source( $_ ); | |
$s->register_class( $_ => $class ); | |
} | |
return $s->resultset( 'Distribution' ); | |
} | |
sub deps { | |
my ( $dist ) = @_; | |
my $dist_obj = $dists->find( $_[0] ); | |
return if !$dist_obj; | |
my $req_links = $dist_obj->search_related( 'req_links' ); | |
my $reqs = $req_links->search_related( 'req' ); | |
my %deps = map { $_ => 1 } $reqs->get_column( 'distribution' )->all; | |
return keys %deps; | |
} | |
sub get_dists_by_short_name { | |
my $dbh = DBI->connect( "dbi:SQLite:dbname=c:/Perl/cpanidx/cpanidx.db", "", "" ); | |
my $long_dists = $dbh->selectall_arrayref( "select * from dists", { Slice => {} } ); | |
my %dists; | |
push @{ $dists{ $_->{dist_name} } }, $_ for @{$long_dists}; | |
return %dists; | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment