view release on metacpan or  search on metacpan

t/lib/Test.pm  view on Meta::CPAN

package t::lib::Test;
use 5.12.0;
use warnings;
use parent 'Test::Builder::Module';

use Test::More;
use Test::Differences;
use Time::HiRes qw(usleep);
use File::Temp ();
use File::Spec;
use Capture::Tiny qw(capture);
use Pod::Usage;
use Scalar::Util qw(reftype);
use Config;
use if $Config{usethreads}, 'threads';

require feature;

our @EXPORT = (
  @Test::More::EXPORT,
  @Test::Differences::EXPORT,
  qw(
        get_process_id
        get_traces
        get_samples
        get_sources
        numify
        precision_factor
        run_ctests
        spawn
        get_process_tree
        get_childs
        take_sample
        temp_profile_dir
        temp_profile_file
        visual_test
        sub_at_line
        $TEST_PM
        $SLOWOPS_PM
        %Config
  )
);

our ($TAKE_SAMPLE_LINE, $SPAWN_LINE);
our $TEST_PM = $INC{'t/lib/Test.pm'};
our $SLOWOPS_PM; # assigned in Slowops.pm

sub import {
    unshift @INC, 't/lib';

    strict->import;
    warnings->import;
    feature->import(':5.12');

    if ((grep /^:fork$/, @_) && !$Config{d_fork}) {
        __PACKAGE__->builder->skip_all("fork() not available");
    }
    if ((grep /^:threads$/, @_) && !$Config{usethreads}) {
        __PACKAGE__->builder->skip_all("threads not available");
    }
    if ((grep /^:spawn$/, @_) && !$Config{usethreads} && !$Config{d_fork}) {
        __PACKAGE__->builder->skip_all("neither fork nor threads available");
    }
    if ((grep /^:visual$/, @_) && (!@ARGV || $ARGV[0] ne '-visual')) {
        __PACKAGE__->builder->skip_all("run with perl -Mblib $0 -visual");
    }

    @_ = grep !/^:(?:fork|threads|spawn|visual)$/, @_;

    goto &Test::Builder::Module::import;
}

sub temp_profile_file {
    state $debugging = $ENV{DEBUG};
    state $tmpdir = File::Temp::tempdir(CLEANUP => !$debugging);
    my $file = File::Temp::mktemp(File::Spec->catfile($tmpdir, "tprof.outXXXXXXXX"));
    if ($debugging) {
        say "# Temporary profiling output file: '$file'";
    }
    return $file;
}

sub temp_profile_dir {
    state $debugging = $ENV{DEBUG};
    my $tmpdir = File::Temp::tempdir(CLEANUP => !$debugging);
    my $file = File::Spec->catfile($tmpdir, "tprof.out");
    if ($debugging) {
        say "# Temporary profiling output file: '$file'";
    }
    return ($tmpdir, $file);
}

sub take_sample {
    usleep(5000 * precision_factor()); BEGIN { $TAKE_SAMPLE_LINE = __LINE__ }
}

my $IS_DISTRIBUTION = $ENV{IS_DISTRIBUTION} // -f 'META.json';
if ($IS_DISTRIBUTION) {
    require Devel::StatProfiler;

    Devel::StatProfiler::Test::test_enable();
}

sub get_process_id {
    my ($file) = @_;
    my $r = Devel::StatProfiler::Reader->new($file);

    return $r->get_genealogy_info->[0];
}

sub get_traces {