view release on metacpan or  search on metacpan

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

use strict;
use warnings;
use 5.020;
our $VERSION = "1.0.0";

our $CONFIG_FILE = '.coveralls.yml';
our $API_ENDPOINT_STEM = '/api/v1/jobs';
our $API_ENDPOINT = 'https://coveralls.io';
our $SERVICE_NAME = 'coveralls-perl';

use Devel::Cover::DB;
use HTTP::Tiny;
use JSON::PP;
use YAML;
use Data::Dumper;

sub get_source {
    my ($file, $callback) = @_;

    my $source = '';
    my @coverage;

    open my $fh, '<', $file or warn("Unable to open $file: $!\n"), return;

    while (defined(my $l = <$fh>)) {
        chomp $l;
        my $n = $.;

        $source .= "$l\n";
        push @coverage, $callback->($n);
    }

    close($fh);

    $file =~ s!^blib/!!;

    return +{
        name => $file,
        source => $source,
        coverage => \@coverage,
    };
}

sub git_log {
    my $format = shift;

    my $text = '';

    # No quotes around the format: cmd.exe on Windows does not take single quotes as quotes, so git
    # would print them. The formats used here have no spaces and no characters a shell changes.
    my $command = "git log -1 --encoding=UTF-8 --pretty=format:$format";
    if (open(my $fh, '-|:encoding(UTF-8)', $command)) {
        $text = do { local $/; <$fh> };
        close $fh;
    }

    return $text;
}

# Turn the output of `git remote -v` into the list of remotes to send.
# Each remote is listed once (its fetch URL), and credentials are removed
# from the URL.
sub parse_git_remotes {
    my $text = shift;

    my @remotes;
    for my $line (split /\n/, defined $text ? $text : '') {
        # "<name>\t<url> (fetch)". The URL may contain spaces (a local path).
        next unless $line =~ /^(\S+)\t(.*) \(fetch\)\r?$/;
        push @remotes, +{ name => $1, url => strip_url_credentials($2) };
    }

    return \@remotes;
}

# Remove the user information from a URL with a scheme
# (https://user:pass@host/path -> https://host/path).
# scp-like URLs (git@host:path) cannot hold a password and are kept as they are.
sub strip_url_credentials {
    my $url = shift;
    $url =~ s!^([A-Za-z][A-Za-z0-9+.-]*://)[^/?#]*@!$1!;
    return $url;
}

sub get_git_info {
    my $git = {
        head => {
            id              => git_log('%H'),
            author_name     => git_log('%aN'),
            author_email    => git_log('%ae'),
            committer_name  => git_log('%cN'),
            committer_email => git_log('%ce'),
            message         => git_log('%s')
        },
        remotes => parse_git_remotes(scalar `git remote -v`),
    };
    my ($branch,) = grep { /^\* / } split( "\n", `git branch` );
    $branch =~ s/^\* //;
    $git->{branch} = $branch;

    if ($ENV{BUILD_SOURCEBRANCHNAME}) {
        $git->{branch} = $ENV{BUILD_SOURCEBRANCHNAME};
    }

    return $git;
}

# A switch in an environment variable (COVERALLS_PARALLEL, COVERALLS_NO_FAIL) is on unless it is
# unset, empty, "false" or "0", as COVERALLS_PARALLEL is in the official coverage-reporter.
sub is_enabled {
    my $value = shift;
    return defined $value && $value ne '' && $value ne 'false' && $value ne '0';
}

# Reads the response of the jobs API (an HTTP::Tiny response). Returns the URL of the job, or
# undef and the error to show.
sub parse_response {
    my $response = shift;
    my $content = $response->{content} // '';
    my $res = eval { decode_json $content };
    my $status = "$response->{status} $response->{reason}";
    if (!$res || ref $res ne 'HASH') {
        # HTTP::Tiny puts its own error (e.g. a failed connection) into the content, with status 599.
        # An error page from a proxy can be long, so only its start is shown.
        $content =~ s/\s+\z//;
        $content = substr($content, 0, 200) . '...' if length $content > 200;
        return (undef, "$status: $content");
    }
    # A job that was registered always has its URL.
    return ($res->{url}, undef) if $response->{success} && $res->{url};
    return (undef, $res->{message} || $status);
}

# The number of the pull request in the event payload of GitHub Actions, or undef.
sub github_event_pull_request {
    my $path = shift;
    return undef unless $path;
    open my $fh, '<:raw', $path or return undef;
    my $event = eval { local $/; decode_json scalar <$fh> } or return undef;