view release on metacpan or  search on metacpan

script/check-all-metric-coverage  view on Meta::CPAN

#!/usr/bin/env perl

# IMPORTANT: this checker has to tell four different failures apart, because
# responding to one of them as if it were another is what costs whole rounds.
# A coverage SHORTFALL is a fact about the code. An UNREADABLE report is a fact
# about the report. An INSTRUMENT FAILURE is a fact about the environment: the
# coverage database was written by one serializer and is being read by another,
# and re-running produces the identical error. Each gets its own exit status so
# a caller never has to parse prose to know which one it is.

use strict;
use warnings;

use Config;
use File::Spec;
use Getopt::Long qw(GetOptions);

use constant EXIT_CLEAN      => 0;
use constant EXIT_SHORTFALL  => 1;
use constant EXIT_UNREADABLE => 2;
use constant EXIT_INSTRUMENT => 3;
use constant EXIT_STALE       => 4;

# The parse errors Devel::Cover surfaces when the reader's serializer is not the
# one that wrote the database. Neither text names the real cause, which is why
# they are matched here and translated into a verdict that does.
my @INSTRUMENT_SIGNATURES = (
    qr/File is not a perl storable/i,
    qr/Bad Sereal header/i,
    qr/Storable binary image v\d+\.\d+ more recent than I am/i,
    qr/Can't load either JSON or Storable/i,
);

exit main(@ARGV);

# Purpose: classify a Devel::Cover text report arriving on standard input.
# Input: the raw @ARGV list; only --database is accepted, naming the coverage
#        database to sniff when an instrument failure has to be explained.
# Output: an exit code - 0 all four metrics at 100.0, 1 a genuine shortfall,
#         2 the report could not be read, 3 the instrument could not read its
#         own database.
sub main {
    my @argv = @_;

    my $database = 'cover_db';
    local @ARGV = @argv;
    GetOptions( 'database=s' => \$database )
        or return _unreadable('unrecognized option; only --database is accepted');
    return _unreadable( 'unexpected argument: ' . join ' ', @ARGV ) if @ARGV;

    my @lines = <STDIN>;

    # Echo the report first and flush it, so the verdict written to standard
    # error cannot appear above the table it is a verdict about. Standard output
    # is block-buffered whenever this runs in a pipeline, which is always.
    local $| = 1;
    print @lines;

    my $signature = _instrument_signature( \@lines );
    return _instrument( $signature, $database ) if defined $signature;

    return _unreadable('no coverage report arrived on standard input; the report was never produced')
        if !grep { /\S/ } @lines;

    return _check_report( \@lines );
}

# Purpose: find the first input line that is a serializer parse error rather
#          than report content.
# Input: an array reference of report lines.
# Output: the offending line with trailing whitespace removed, or undef.
sub _instrument_signature {
    my ($lines) = @_;

    for my $line ( @{$lines} ) {
        for my $signature (@INSTRUMENT_SIGNATURES) {
            next if $line !~ $signature;
            my $trimmed = $line;
            $trimmed =~ s/\s+\z//;
            return $trimmed;
        }
    }

    return undef;
}

# Purpose: report a serializer mismatch as an instrument failure, naming the
#          format on disk, the format this reader would choose, and every
#          Devel::Cover::DB::IO this process can see.
# Input: the offending reader message and the coverage database directory.
# Output: EXIT_INSTRUMENT, after writing the verdict to standard error.
sub _instrument {
    my ( $message, $database ) = @_;

    my ( $written, $source ) = _database_format($database);
    my $read  = _reader_format();
    my @paths = _io_module_paths();

    print {*STDERR} <<"VERDICT";
coverage gate: INSTRUMENT FAILURE - the coverage database could not be read.
coverage gate: the reader said: $message
coverage gate: written as: $written ($source)
coverage gate: read as:    $read (the serializer this process resolves)
coverage gate: Devel/Cover/DB/IO.pm visible here: @{[ join '; ', @paths ]}
coverage gate: Devel::Cover::DB::IO chooses Sereal, then JSON, then Storable at
coverage gate: BEGIN from \@INC, and never records the choice beside the data, so