view release on metacpan or  search on metacpan

lib/Trace/Mask/Test.pm  view on Meta::CPAN

package Trace::Mask::Test;
use strict;
use warnings;

use Trace::Mask::Util qw/mask_frame mask_line mask_call/;
use Trace::Mask::Reference qw/trace/;

use Carp qw/croak/;
use Scalar::Util qw/reftype/;
use List::Util qw/min/;

use base 'Exporter';
our @EXPORT = qw{test_tracer NA};
our @EXPORT_OK = qw{
    test_stack_hide test_stack_shift test_stack_stop test_stack_no_start
    test_stack_alter test_stack_shift_and_hide test_stack_shift_short
    test_stack_hide_short test_stack_shift_and_alter test_stack_full_combo
    test_stack_restart test_stack_special test_stack_lock
};

sub NA() { \&NA }

sub test_tracer {
    my %params = @_;
    my $convert = delete $params{convert};
    my $trace   = delete $params{trace};
    my $name    = delete $params{name} || 'tracer test';
    my $type    = delete $params{type} || 'return';

    croak "your must provide a 'convert' callback coderef"
        unless $convert && ref($convert) && reftype($convert) eq 'CODE';

    croak "your must provide a 'trace' callback coderef"
        unless $trace && ref($trace) && reftype($trace) eq 'CODE';

    my %tests;
    if (keys %params) {
        my @bad;

        for my $test (keys %params) {
            my $sub;
            $sub = __PACKAGE__->can($test) if !ref($test) && $test =~ m/^test_/ && $test !~ m/test_tracer/;
            if($sub && ref($sub) && reftype($sub) eq 'CODE') {
                $tests{$test} = $sub;
            }
            else{
                push @bad => $test;
            }
        }

        croak "Invalid test(s): " . join(', ', map {"'$_'"} sort @bad)
            if @bad;
    }
    else {
        for my $sym (keys %Trace::Mask::Test::) {
            next unless $sym =~ m/^test_/;
            next if $sym =~ m/test_tracer/;
            my $sub = __PACKAGE__->can($sym) || next;
            $tests{$sym} = $sub;
        }
    }

    require Test2::Tools::Compare;
    require Test2::Tools::Subtest;
    require Test2::API;

    my $ctx = Test2::API::context();

    my $results = {};
    my $expects = {};
    my $ok;
    my $sig_die = $SIG{__DIE__};

    Test2::Tools::Subtest::subtest_buffered($name => sub {
        local $SIG{__DIE__} = $sig_die;
        my $sctx = Test2::API::context();
        $sctx->set_trace($ctx->trace);
        for my $test (sort keys %tests) {
            my $sub = $tests{$test};
            my $result;
            {