view release on metacpan or  search on metacpan

share/PerlCritic/Critic/TestUtils.pm  view on Meta::CPAN

            throw_internal "Got some code but I'm not in a subtest: $test_file";
        }
    }
    close $fh or throw_generic "unable to close $test_file: $OS_ERROR";
    if ( $subtest ) {
        if ( $incode ) {
            push @subtests, _finalize_subtest( $subtest );
        }
        else {
            throw_internal "Incomplete subtest in $test_file";
        }
    }

    return @subtests;
}

sub _finalize_subtest {
    my $subtest = shift;

    if ( $subtest->{code} ) {
        $subtest->{code} = join "\n", @{$subtest->{code}};
    }
    else {
        throw_internal "$subtest->{name} has no code lines";
    }
    if ( !defined $subtest->{failures} ) {
        throw_internal "$subtest->{name} does not specify failures";
    }
    if ($subtest->{parms}) {
        $subtest->{parms} = eval $subtest->{parms}; ## no critic(StringyEval)
        if ($EVAL_ERROR) {
            throw_internal
                "$subtest->{name} has an error in the 'parms' property:\n"
                  . $EVAL_ERROR;
        }
        if ('HASH' ne ref $subtest->{parms}) {
            throw_internal
                "$subtest->{name} 'parms' did not evaluate to a hashref";
        }
    } else {
        $subtest->{parms} = {};
    }

    if (defined $subtest->{error}) {
        if ( $subtest->{error} =~ m{ \A / (.*) / \z }xms) {
            $subtest->{error} = eval {qr/$1/}; ## no critic (ExtendedFormatting LineBoundaryMatching DotMatchAnything)
            if ($EVAL_ERROR) {
                throw_internal
                    "$subtest->{name} 'error' has a malformed regular expression";
            }
        }
    }

    return $subtest;
}

sub bundled_policy_names {
    require ExtUtils::Manifest;
    my $manifest = ExtUtils::Manifest::maniread();
    my @policy_paths = map {m{\A lib/(Perl/Critic/Policy/.*).pm \z}xms} keys %{$manifest};
    my @policies = map { join q{::}, split m{/}xms, $_} @policy_paths;
    my @sorted_policies = sort @policies;
    return @sorted_policies;
}

sub names_of_policies_willing_to_work {
    my %configuration = @_;

    my @policies_willing_to_work =
        Perl::Critic::Config
            ->new( %configuration )
            ->policies();

    return map { ref $_ } @policies_willing_to_work;
}

1;

__END__

#-----------------------------------------------------------------------------

=pod

=for stopwords RCS subtest subtests

=head1 NAME

Perl::Critic::TestUtils - Utility functions for testing new Policies.


=head1 INTERFACE SUPPORT

This is considered to be a public module.  Any changes to its
interface will go through a deprecation cycle.


=head1 SYNOPSIS

    use Perl::Critic::TestUtils qw(critique pcritique fcritique);

    my $code = '<<END_CODE';
    package Foo::Bar;
    $foo = frobulator();
    $baz = $foo ** 2;
    1;
    END_CODE

    # Critique code against all loaded policies...
    my $perl_critic_config = { -severity => 2 };
    my $violation_count = critique( \$code, $perl_critic_config);

    # Critique code against one policy...
    my $custom_policy = 'Miscellanea::ProhibitFrobulation'
    my $violation_count = pcritique( $custom_policy, \$code );

    # Critique code against one filename-related policy...
    my $custom_policy = 'Modules::RequireFilenameMatchesPackage'
    my $violation_count = fcritique( $custom_policy, \$code, 'Foo/Bar.pm' );