view release on metacpan or  search on metacpan

lib/Test/Perl/Critic/Policy.pm  view on Meta::CPAN

    if ( not $ok = $have == $want ) {
        my $msg = qq(Expected $want violations, got $have. );
        if (@violations) { $msg .= q(Found violations follow...); }
        push @diagnostics, $msg . "\n";
        push @diagnostics, map { qq(Found violation: $_) } @violations;
    }

    return ($ok, @diagnostics);
}

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

sub _evaluate_error_case {
    my ($subtest, $error) = @_;
    my ($ok, @diagnostics);

    if ( 'Regexp' eq ref $subtest->{error} ) {
        $ok = $error =~ $subtest->{error}
          or push @diagnostics, qq(Error message '$error' doesn't match $subtest->{error}.);
    }
    else {
        $ok = $subtest->{error}
          or push @diagnostics, q(Didn't get an error message when we expected one.);
    }

    return ($ok, @diagnostics);
}

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

sub _compute_test_count {
    my ($subtests_with_extras) = @_;

    # one can_ok() for each policy
    my $npolicies = scalar keys %{ $subtests_with_extras };

    my $nsubtests = 0;
    for my $subtest_with_extras ( values %{$subtests_with_extras} ) {
        # one [pf]critique() test per subtest
        $nsubtests += @{ $subtest_with_extras->{subtests} };
    }

    return $nsubtests + $npolicies;
}

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

sub _compute_wanted_violation_count {
    my ($subtest) = @_;

    # If any optional modules are NOT available, then there should be no violations.
    return 0 if not _all_optional_modules_are_available($subtest);
    return $subtest->{failures};
}

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

sub _all_optional_modules_are_available {
    my ($subtest) = @_;
    my $optional_modules = $subtest->{optional_modules} or return 1;
    return all {eval "require $_;" or 0;} split m/,\s*/xms, $optional_modules;
}

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

sub _create_test_name {
    my ($policy, $subtest) = @_;
    return join ' - ', $policy, "line $subtest->{lineno}", $subtest->{name};
}

#-----------------------------------------------------------------------------
1;

__END__

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

=pod

=for stopwords subtest subtests RCS

=head1 NAME

Test::Perl::Critic::Policy - A framework for testing your custom Policies

=head1 SYNOPSIS

    use Test::Perl::Critic::Policy qw< all_policies_ok >;

    # Assuming .run files are inside 't' directory...
    all_policies_ok()

    # Or if your .run files are in a different directory...
    all_policies_ok( '-test-directory' => 'run' );

    # And if you just want to run tests for some polices...
    all_policies_ok( -policies => ['Some::Policy', 'Another::Policy'] );

    # If you want your test program to accept short Policy names as
    # command-line parameters...
    #
    # You can then test a single policy by running
    # "perl -Ilib t/policy-test.t My::Policy".
    my %args = @ARGV ? ( -policies => [ @ARGV ] ) : ();
    all_policies_ok(%args);


=head1 DESCRIPTION

This module provides a framework for function-testing your custom
L<Perl::Critic::Policy|Perl::Critic::Policy> modules.  Policy testing usually
involves feeding it a string of Perl code and checking its behavior.  In the
old days, those strings of Perl code were mixed directly in the test script.
That sucked.

=head1 IMPORTABLE SUBROUTINES

=over

=item all_policies_ok('-test-directory' => $path, -policies => \@policy_names)