libdevel-cover-perl 1.23-2+b1 / usr / lib / x86_64-linux-gnu / perl5 / 5.24 / Devel / Cover / Test.pm

# Copyright 2002-2016, Paul Johnson (paul@pjcj.net)

# This software is free.  It is licensed under the same terms as Perl itself.

# The latest version of this software should be available from my homepage:
# http://www.pjcj.net

package Devel::Cover::Test;

use strict;
use warnings;

our $VERSION = '1.23'; # VERSION

use Carp;

use File::Spec;
use Test::More;

use Devel::Cover::Inc;

sub new {
    my $class = shift;
    my $test  = shift;
    croak "No test specified" unless $test;
    my %params = @_;

    my $criteria = delete $params{criteria} ||
                   "statement branch condition subroutine";

    eval "use Test::Differences";
    my $differences = $INC{"Test/Differences.pm"};

    my $self = bless {
        test             => $test,
        criteria         => [ $criteria ],
        skip             => "",
        uncoverable_file => [],
        select           => "",
        ignore           => [],
        changes          => [],
        test_parameters  => [],
        debug            => $ENV{DEVEL_COVER_DEBUG} || 0,
        differences      => $differences,
        no_coverage      => $ENV{DEVEL_COVER_NO_COVERAGE} || 0,
        delay_after_run  => 0,
        %params
    }, $class;

    $self->get_params
}


sub set_test {
    my $self      = shift;
    my ($test)    = @_;
    $self->{test} = $test;
}

sub shell_quote {
    my ($item) = @_;
    $^O eq "MSWin32" ? (/ / and $_ = qq("$_")) : s/ /\\ /g for $item;
    $item
};

sub get_params {
    my $self = shift;

    my $test = $self->test_file;
    if (open T, $test) {
        while (<T>) {
            push @{$self->{$1}}, $2 if /__COVER__\s+(\w+)\s+(.*)/;
        }
        close T or die "Cannot close $test: $!";
    }

    $self->{criteria}         = $self->{criteria}[-1];
    $self->{select}         ||= "-select /tests/$self->{test}\\b";
    $self->{test_parameters}  = "$self->{select}"
                              . " -ignore blib Devel/Cover @{$self->{ignore}}"
                              . " -merge 0 -coverage $self->{criteria} "
                              . "@{$self->{test_parameters}}";
    $self->{criteria}         =~ s/-\w+//g;
    $self->{db_name}        ||= $self->{test};
    $self->{cover_db}         = "$Devel::Cover::Inc::Base/t/e2e/"
                              . "cover_db_$self->{db_name}/";
    unless (mkdir $self->{cover_db}) {
        die "Can't mkdir $self->{cover_db}: $!" unless -d $self->{cover_db};
    }
    $self->{cover_parameters} = join(" ", map "-coverage $_",
                                              split " ", $self->{criteria})
                              . " -report text "
                              . shell_quote $self->{cover_db};
    $self->{cover_parameters} .= " -uncoverable_file "
                              .  "@{$self->{uncoverable_file}}"
        if @{$self->{uncoverable_file}};
    if (exists $self->{skip_test}) {
        for my $s (@{$self->{skip_test}}) {
            my $r = shift @{$self->{skip_reason}};
            next unless eval "{$s}";
            $self->{skip} = $r;
            last;
        }
    }

    $self
}

sub perl {
    my $self = shift;
    join " ",
         map shell_quote($_),
             $Devel::Cover::Inc::Perl,
             map "-I$Devel::Cover::Inc::Base/$_", "", "blib/lib", "blib/arch"
}

sub test_command {
    my $self = shift;

    my $c = $self->perl;
    unless ($self->{no_coverage}) {
        $c .= " "
           .  shell_quote "-MDevel::Cover=" .
                          join(",", "-db", $self->{cover_db},
                                    split " ", $self->{test_parameters});
    }
    $c .= " " . shell_quote $self->test_file;
    $c .= " " . $self->test_file_parameters;

    $c
}

sub cover_command {
    my $self = shift;
    my $b = shell_quote $Devel::Cover::Inc::Base;
    my $c = $self->perl . " $b/bin/cover $self->{cover_parameters}";
    $c
}

sub test_file {
    my $self = shift;
    "$Devel::Cover::Inc::Base/tests/$self->{test}"
}

sub test_file_parameters {
    my $self = shift;
    exists $self->{test_file_parameters} ? $self->{test_file_parameters} : ""
}

sub cover_gold {
    my $self = shift;

    my $test = $self->{golden_test} || $self->{test};

    my $td = "$Devel::Cover::Inc::Base/test_output/cover";
    opendir D, $td or die "Can't opendir $td: $!";
    my @versions = sort    { $a <=> $b }
                   map     { /^$test\.(5\.\d+)$/ ? $1 : () }
                   readdir D;
    closedir D or die "Can't closedir $td: $!";
    # print STDERR "Versions for [$test] from [$td] @versions\n";

    my $v = "5.0";
    for (@versions) {
        last if $_ > $];
        $v = $_;
    }

    # die "Can't find golden results for $test" if $v eq "5.0";

    $v = $ENV{DEVEL_COVER_GOLDEN_VERSION}
        if exists $ENV{DEVEL_COVER_GOLDEN_VERSION};

    ("$td/$test", $v eq "5.0" ? 0 : $v)
}

sub run_command {
    my $self = shift;
    my ($command) = @_;

    print STDERR "Running test [$command]\n" if $self->{debug};

    open T, "$command 2>&1 |" or die "Cannot run $command: $!";
    while (<T>) {
        print STDERR if $self->{debug};
    }
    close T or die "Cannot close $command: $!";

    if ($self->{delay_after_run}) {
        eval { select undef, undef, undef, $self->{delay_after_run}; 1 } or
            sleep int $self->{delay_after_run} + 1;
    }

    1
}

sub run_test {
    my $self = shift;

    if ($] < 5.008001) {
        plan skip_all => "Perl version $] is not supported";
        return;
    }

    if ($self->{skip}) {
        plan skip_all => $self->{skip};
        return;
    }

    my $version = int(($] - 5) * 1000 + 0.5);
    if ($version % 2 && $version < 22) {
        plan skip_all => "Perl version $] is an obsolete development version";
        return;
    }

    my ($base, $v) = $self->cover_gold;
    # print STDERR "[$base,$v]\n";
    return 1 unless $v;  # assume we are generating the golden results
    my $gold = "$base.$v";

    open I, $gold or die "Cannot open $gold: $!";
    my @cover = <I>;
    close I or die "Cannot close $gold: $!";
    $self->{cover} = \@cover;

    # print STDERR "gold from $gold\n", @cover if $self->{debug};

    plan tests => $self->{differences}
        ? 1
        : exists $self->{tests}
            ? $self->{tests}->(scalar @cover)
            : scalar @cover;

    local $ENV{PERL5OPT};
    $self->{run_test}
        ? $self->{run_test}->($self)
        : $self->run_command($self->test_command);
    $self->run_cover unless $self->{no_report};
    $self->{end}->() if $self->{end};

    1
}

sub run_cover {
    my $self = shift;

    my $cover_com = $self->cover_command;
    print STDERR "Running cover [$cover_com]\n" if $self->{debug};

    my (@at, @ac);
    my $change_line = sub {
        my ($get_line) = @_;
        local *_;
        LOOP:
        while (1) {
            $_ = scalar $get_line->();
            $_ = "" unless defined $_;
            print STDERR $_ if $self->{debug};
            redo if /^Devel::Cover: merging run/;
            redo if /^Set up gcc environment/;  # for MinGW
            if (/Can't opendir\(.+\): No such file or directory/) {
                # parallel tests
                scalar $get_line->();
                redo;
            }
            s/^(Reading database from ).*/$1/;
            s|(__ANON__\[) .* (/tests/ \w+ : \d+ \])|$1$2|x;
            s/(Subroutine) +(Location)/$1 $2/;
            s/-+/-/;
            # s/.* Devel-Cover - \d+ \. \d+ \/*(\S+)\s*/$1/x;
            s/^ \.\.\. .* - \d+ \. \d+ \/*(\S+)\s*/$1/x;
            s/.* Devel \/ Cover \/*(\S+)\s*/$1/x;
            s/^(Devel::Cover: merging run).*/$1/;
            s/^(Run: ).*/$1/;
            s/^(OS: ).*/$1/;
            s/^(Perl version: ).*/$1/;
            s/^(Start: ).*/$1/;
            s/^(Finish: ).*/$1/;
            s/copyright .*//ix;
            no warnings "exiting";
            eval join "; ", @{$self->{changes}};
            return $_;
        }
    };

    # use Devel::Cover::Dumper; print STDERR "--->", Dumper $self->{changes};
    open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!";
    while (!eof T) {
        my $t = $change_line->(sub { <T>                     });
        my $c = $change_line->(sub { shift @{$self->{cover}} });
        # print STDERR "[$t]\n[$c]\n" if $t ne $c;
        do {
            chomp(my $tn = $t); chomp(my $cn = $c);
            print STDERR "c-[$tn] $.\ng=[$cn]\n";
        } if $self->{debug};

        if ($self->{differences}) {
            push @at, $t;
            push @ac, $c;
        } else {
            $self->{no_coverage} ? pass : is($t, $c);
            last if $self->{no_coverage} && !@{$self->{cover}};
        }
    }
    if ($self->{differences}) {
        no warnings "redefine";
        local *Test::_quote = sub { "@_" };
        $self->{no_coverage} ? pass : eq_or_diff(\@at, \@ac, "output");
    } elsif ($self->{no_coverage}) {
        pass for @{$self->{cover}};
    }
    close T or die "Cannot close $cover_com: $!";

    1
}

sub create_gold {
    my $self = shift;

    # Pod::Coverage not available on all versions, but it must be there on
    # 5.8.1
    return if $self->{criteria} =~ /\bpod\b/ && $] != 5.008001;

    my ($base, $v) = $self->cover_gold;
    my $gold       = "$base.$v";
    my $new_gold   = "$base.$]";
    my $gv         = $v;
    my $ng         = "";

    unless (-e $new_gold) {
        open my $g, ">$new_gold" or die "Can't open $new_gold: $!";
        unlink $new_gold;
    }

    # use Devel::Cover::Dumper; print STDERR Dumper $self;
    if ($self->{skip}) {
        print STDERR "Skipping: $self->{skip}\n";
        return;
    }

    $self->{run_test}
        ? $self->{run_test}->($self)
        : $self->run_command($self->test_command);

    my $cover_com = $self->cover_command;
    print STDERR "Running cover [$cover_com]\n" if $self->{debug};

    open G, ">$new_gold" or die "Cannot open $new_gold: $!";
    open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!";
    while (my $l = <T>) {
        next if $l =~ /^Devel::Cover: merging run/;
        $l =~ s/^($_: ).*$/$1.../
            for "Run", "Perl version", "OS", "Start", "Finish";
        $l =~ s/^(Reading database from ).*$/$1.../;
        print STDERR $l if $self->{debug};
        print G $l;
        $ng .= $l;
    }
    close T or die "Cannot close $cover_com: $!";
    close G or die "Cannot close $new_gold: $!";

    print STDERR "gv is $gv and this is $]\n" if $self->{debug};
    print STDERR "gold is $gold and new_gold is $new_gold\n" if $self->{debug};
    unless ($gv eq "0" || $gv eq $]) {
        open G, "$gold" or die "Cannot open $gold: $!";
        my $g = do { local $/; <G> };
        close G or die "Cannot close $gold: $!";

        print STDERR "checking $new_gold against $gold\n" if $self->{debug};
        # print "--[$ng]--\n";
        # print "--[$g]--\n";
        if ($ng eq $g) {
            print STDERR "matches $v";
            unlink $new_gold;
        } else {
            print STDERR "new";
        }
    }

    $self->{end}->() if $self->{end};

    1
}

1

__END__

=head1 NAME

Devel::Cover::Test - Internal module for testing

=head1 VERSION

version 1.23

=head1 METHODS

=cut

=head2 new

  my $test = Devel::Cover::Test->new($test, criteria => $string)

Constructor.

"criteria" parameter (optional, defaults to "statement branch condition
subroutine") is a space separated list of tokens.
Supported tokens are "statement", "branch", "condition", "subroutine" and
"pod".

More optional parameters are supported. Refer to L</get_params> sub.

=head2 shell_quote

  my $quoted_item = shell_quote($item)

Returns properly quoted item to cope with embedded spaces.

=head2 perl

  my $perl = $self->perl

Returns absolute path to Perl interpreter with proper -I options (blib-wise).

=head2 test_command

  my $command = $self->test_command

Returns test command, made of:

=over 4

=item absolute path to Perl interpreter

=item Devel::Cover -M option (if applicable)

=item test file

=item test file parameters (if applicable)

=back

=head2 cover_command

  my $command = $self->cover_command

Returns test command, made of:

=over 4

=item absolute path to Perl interpreter

=item absolute path to cover script

=item cover parameters

=back

=head2 test_file

  my $file = $self->test_file

Returns absolute path to test file.

=head2 test_file_parameters

  my $parameters = $self->test_file_parameters

Accessor to test_file_parameters property.

=head2 cover_gold

  my ($base, $v) = $self->cover_gold;

Returns the absolute path of the base to the golden file and the suffix
version number.

$base comes from the name of the test and $v will be $] from the earliest perl
version for which the golden results should be the same as for the current $]

=head2 run_command

  $self->run_command($command)

Runs command, most likely obtained from L</test_command> sub.

=head1 BUGS

Huh?

=head1 LICENCE

Copyright 2001-2016, Paul Johnson (paul@pjcj.net)

This software is free.  It is licensed under the same terms as Perl itself.

The latest version of this software should be available from my homepage:
http://www.pjcj.net

=cut