view release on metacpan or  search on metacpan

lib/Devel/Cover/Report/OwnServer.pm  view on Meta::CPAN

package Devel::Cover::Report::OwnServer;

use 5.010001;
use strict;
use warnings;
use version; our $VERSION = qv( sprintf '0.4.%d', q$Rev: 1 $ =~ /\d+/gmx );

use Getopt::Long;
use HTTP::Tiny;
use JSON::PP qw( decode_json encode_json );

my $URI_TEMPLATE = 'http://localhost:5000/coverage/report/%s';

# Private subroutines
my $run = sub {
   my $cmd = shift; return qx( $cmd );
};

my $get_git_info = sub {
   my ($dist, $version) = @_;

   my ($branch) =  grep { m{ \A \* }mx } split "\n", $run->( 'git branch' );
       $branch  =~ s{ \A \* \s* }{}mx;
   my $remotes  =  [ map    { my ($name, $url) = split q( ), $_;
                              +{ name => $name, url => $url } }
                     split m{ \n }mx, $run->( 'git remote -v' ) ];

   return { author_name     => $run->( 'git log -1 --pretty=format:"%aN"' ),
            author_email    => $run->( 'git log -1 --pretty=format:"%ae"' ),
            branch          => $branch,
            commit          => $run->( 'git log -1 --pretty=format:"%H"' ),
            committer_name  => $run->( 'git log -1 --pretty=format:"%cN"' ),
            committer_email => $run->( 'git log -1 --pretty=format:"%ce"' ),
            coverage_token  => $ENV{COVERAGE_TOKEN} // '[?]',
            dist_name       => $dist,
            message         => $run->( 'git log -1 --pretty=format:"%s"' ),
            remotes         => $remotes,
            version         => $version, };
};

# Public methods
sub get_options {
   my ($self, $opt) = @_;

   $opt->{option}->{uri_template} = $ENV{COVERAGE_URI} // $URI_TEMPLATE;

   GetOptions( $opt->{option}, 'uri_template=s' )
      or die 'Invalid command line options';

   return;
}

sub report {
   my (undef, $db, $config) = @_;

   my %options = map  { $_ => 1 }
                 grep { not m{ path|time }mx } $db->all_criteria, 'force';

   $db->calculate_summary( %options );

   my $dist    = (($db->runs)[ 0 ])->name;
   my $version = (($db->runs)[ 0 ])->version;
   # Use the hash since there is a bug: use of uninitialized value $file in
   # hash element at Devel/Cover/DB.pm line 324.
   my $report  = { info    => $get_git_info->( $dist, $version ),
                   summary => $db->{summary} };
   my $http    = HTTP::Tiny->new
      ( default_headers => { 'Content-Type' => 'application/json' } );
   my $uri     = sprintf $config->{option}->{uri_template}, lc $dist;
   my $resp    = $http->post( $uri, { content => encode_json $report } );

   if ($resp->{success}) {
      my $content = decode_json $resp->{content};

      print $content->{message}."\n";
   }
   else {
      warn 'Coverage upload status '.$resp->{status}.': '.$resp->{reason}."\n";
   }

   return;
}

1;

__END__