Login
9815dad173c46661ca2ecd6ae34c6d1f7a3731d3
[gknop/Perl-Critic.git] / t / 06_violation.t
1 #!perl
2
3 ##############################################################################
4 #      $URL$
5 #     $Date$
6 #   $Author$
7 # $Revision$
8 ##############################################################################
9
10 use 5.006001;
11 use strict;
12 use warnings;
13
14 use English qw(-no_match_vars);
15
16 use PPI::Document;
17
18 use Perl::Critic::Utils qw< :characters >;
19
20 use Test::More tests => 41;
21
22 #-----------------------------------------------------------------------------
23
24 our $VERSION = '1.088';
25
26 #-----------------------------------------------------------------------------
27
28 BEGIN {
29     # Needs to be in BEGIN for global vars
30     use_ok('Perl::Critic::Violation');
31 }
32
33 use lib qw< t/06_violation.t.lib >;
34 use ViolationTest;   # this is solely to test the import() method; has diagnostics
35 use ViolationTest2;  # this is solely to test the import() method; no diagnostics
36 use Perl::Critic::Policy::Test;    # this is to test violation formatting
37
38 #-----------------------------------------------------------------------------
39 #  method tests
40
41 can_ok('Perl::Critic::Violation', 'sort_by_location');
42 can_ok('Perl::Critic::Violation', 'sort_by_severity');
43 can_ok('Perl::Critic::Violation', 'new');
44 can_ok('Perl::Critic::Violation', 'location');
45 can_ok('Perl::Critic::Violation', 'diagnostics');
46 can_ok('Perl::Critic::Violation', 'description');
47 can_ok('Perl::Critic::Violation', 'explanation');
48 can_ok('Perl::Critic::Violation', 'filename');
49 can_ok('Perl::Critic::Violation', 'source');
50 can_ok('Perl::Critic::Violation', 'policy');
51 can_ok('Perl::Critic::Violation', 'get_format');
52 can_ok('Perl::Critic::Violation', 'set_format');
53 can_ok('Perl::Critic::Violation', 'to_string');
54
55 #-----------------------------------------------------------------------------
56 # Constructor Failures:
57 eval { Perl::Critic::Violation->new('desc', 'expl'); };
58 ok($EVAL_ERROR, 'new, wrong number of args');
59 eval { Perl::Critic::Violation->new('desc', 'expl', {}, 'severity'); };
60 ok($EVAL_ERROR, 'new, bad arg');
61
62 #-----------------------------------------------------------------------------
63 # Accessor tests
64
65 my $pkg  = __PACKAGE__;
66 my $code = 'Hello World;';
67 my $doc = PPI::Document->new(\$code);
68 my $no_diagnostics_msg = qr/ \s* No [ ] diagnostics [ ] available \s* /xms;
69 my $viol = Perl::Critic::Violation->new( 'Foo', 'Bar', $doc, 99, );
70
71 my $expected_location = [1,1,1];
72
73 is(        $viol->description(), 'Foo',    'description');
74 is(        $viol->explanation(), 'Bar',    'explanation');
75 is_deeply( $viol->location(),    $expected_location,  'location');
76 is(        $viol->severity(),    99,       'severity');
77 is(        $viol->source(),      $code,    'source');
78 is(        $viol->policy(),      $pkg,     'policy');
79 like(      $viol->diagnostics(), qr/ \A $no_diagnostics_msg \z /xms, 'diagnostics');
80
81 {
82     local $Perl::Critic::Violation::FORMAT = '%l,%c,%m,%e,%p,%d,%r';
83     my $expect = qr/\A $expected_location->[0],$expected_location->[1],Foo,Bar,$pkg,$no_diagnostics_msg,\Q$code\E \z/xms;
84
85     like($viol->to_string(), $expect, 'to_string');
86     like("$viol",            $expect, 'stringify');
87 }
88
89 $viol = Perl::Critic::Violation->new('Foo', [28], $doc, 99);
90 is($viol->explanation(), 'See page 28 of PBP', 'explanation');
91
92 $viol = Perl::Critic::Violation->new('Foo', [28,30], $doc, 99);
93 is($viol->explanation(), 'See pages 28,30 of PBP', 'explanation');
94
95
96 #-----------------------------------------------------------------------------
97 # Import tests
98 like(ViolationTest->get_violation()->diagnostics(),
99      qr/ \A \s* This [ ] is [ ] a [ ] test [ ] diagnostic\. \s*\z /xms, 'import diagnostics');
100
101 #-----------------------------------------------------------------------------
102 # Violation sorting
103
104 SKIP: {
105
106     #For reasons I don't yet understand these tests fail
107     #on my perl at work.  So for now, I just skip them.
108     skip( 'Broken on perls <= 5.6.1', 2 ) if $] <= 5.006001;
109
110     $code = <<'END_PERL';
111 my $foo = 1; my $bar = 2;
112 my $baz = 3;
113 END_PERL
114
115     $doc = PPI::Document->new(\$code);
116     my @children   = $doc->schildren();
117     my @violations =
118         map { Perl::Critic::Violation->new($EMPTY, $EMPTY, $_, 0) }
119             $doc, @children;
120     my @sorted = Perl::Critic::Violation->sort_by_location( reverse @violations);
121     is_deeply(\@sorted, \@violations, 'sort_by_location');
122
123     my @severities = (5, 3, 4, 0, 2, 1);
124     @violations =
125         map { Perl::Critic::Violation->new($EMPTY, $EMPTY, $doc, $_) }
126         @severities;
127     @sorted = Perl::Critic::Violation->sort_by_severity( @violations );
128     is_deeply( [map {$_->severity()} @sorted], [sort @severities], 'sort_by_severity');
129 }
130
131 #-----------------------------------------------------------------------------
132 # Violation formatting
133
134 {
135     my $format = '%l; %c; %m; %e; %s; %r; %P; %p; %d';
136     my $expected = join q{; }, (
137        1, 1,  # line, col
138        'desc', 'expl',
139        1, # severity
140        'print;', # source near token[0]
141        'Perl::Critic::Policy::Test', 'Test', # long, short
142        '    diagnostic',
143     );
144
145     Perl::Critic::Violation::set_format($format);
146     is(Perl::Critic::Violation::get_format(), $format, 'set/get_format');
147     $code = "print;\n";
148     $doc = PPI::Document->new(\$code);
149     $doc->index_locations();
150     my $p = Perl::Critic::Policy::Test->new();
151     my @t = $doc->tokens();
152     my $v = $p->violates($t[0]);
153     ok($v, 'got a violation');
154
155     is($v->to_string(), $expected, 'to_string()');
156 }
157
158 #-----------------------------------------------------------------------------
159 # More formatting
160
161 {
162     # Alias subroutines, because I'm lazy
163     my $get_format = *Perl::Critic::Violation::get_format;
164     my $set_format = *Perl::Critic::Violation::set_format;
165
166     my $fmt_literal = 'Found %m in file %f on line %l\n';
167     my $fmt_interp  = "Found %m in file %f on line %l\n"; #Same, but double-quotes
168     is($set_format->($fmt_literal), $fmt_interp, 'set_format by spec');
169     is($get_format->(), $fmt_interp, 'get_format by spec');
170
171     my $fmt_predefined = "%m at %f line %l\n";
172     is($set_format->(3), $fmt_predefined, 'set_format by number');
173     is($get_format->(),  $fmt_predefined, 'get_format by number');
174
175     my $fmt_default = "%m at line %l, column %c.  %e.  (Severity: %s)\n";
176     is($set_format->(999),   $fmt_default, 'set_format by invalid number');
177     is($get_format->(),      $fmt_default, 'get_format by invalid number');
178     is($set_format->(undef), $fmt_default, 'set_format with undef');
179     is($get_format->(),      $fmt_default, 'get_format with undef');
180
181 }
182
183 #-----------------------------------------------------------------------------
184
185 # ensure we run true if this test is loaded by
186 # t/06_violation.t_without_optional_dependencies.t
187 1;
188
189 # Local Variables:
190 #   mode: cperl
191 #   cperl-indent-level: 4
192 #   fill-column: 78
193 #   indent-tabs-mode: nil
194 #   c-indentation-style: bsd
195 # End:
196 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :