wchristian/compare_report_sent.pl

## compare_report_sent.pl
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} = '&#10006;' 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;
}
	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;
	}