Login
Abstract the PPI::Document caching code into a wrapper class,
[gknop/Perl-Critic.git] / lib / Perl / Critic / Violation.pm
CommitLineData
39cd321a
JRT
1#######################################################################
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
c0b487cd 6# ex: set ts=8 sts=4 sw=4 expandtab
39cd321a
JRT
7########################################################################
8
59b05e08
JRT
9package Perl::Critic::Violation;
10
11use strict;
12use warnings;
13use Carp;
14use IO::String;
15use Pod::PlainText;
16use Perl::Critic::Utils;
17use String::Format qw(stringf);
18use English qw(-no_match_vars);
f731cec9 19use overload ( q{""} => q{to_string}, cmp => q{_compare} );
59b05e08 20
8d36cd6f 21our $VERSION = '0.18';
59b05e08
JRT
22$VERSION = eval $VERSION; ## no critic
23
24#Class variables...
25our $FORMAT = "%m at line %l, column %c. %e.\n"; #Default stringy format
1e7b8681 26my %DIAGNOSTICS = (); #Cache of diagnositc messages
59b05e08
JRT
27
28#----------------------------------------------------------------------------
29
30sub import {
31
32 my $caller = caller;
33 return if exists $DIAGNOSTICS{$caller};
34
35 if ( my $file = _mod2file($caller) ) {
0a6f07d0
AL
36 if ( my $diags = _get_diagnostics($file) ) {
37 $DIAGNOSTICS{$caller} = $diags;
38 return; #ok!
39 }
59b05e08
JRT
40 }
41
42 #If we get here, then we couldn't get diagnostics
43 my $no_diags = " No diagnostics available\n";
44 $DIAGNOSTICS{$caller} = $no_diags;
45
46 return; #ok!
47}
48
7e86d49a 49#----------------------------------------------------------------------------
59b05e08
JRT
50
51sub new {
6bf9b465 52 my ( $class, $desc, $expl, $elem, $sev ) = @_;
59b05e08
JRT
53
54 #Check arguments to help out developers who might
55 #be creating new Perl::Critic::Policy modules.
56
41ca89c8 57 if ( @_ != 5 ) {
59b05e08
JRT
58 my $msg = 'Wrong number of args to Violation->new()';
59 croak $msg;
60 }
61
5bf96118
CD
62 if ( ! eval { $elem->isa( 'PPI::Element' ) } ) {
63
64 if ( eval { $elem->isa( 'Perl::Critic::Document' ) } ) {
65 # break the facade, return the real PPI::Document
66 $elem = $elem->{_doc};
67 }
68 else {
69 my $msg = '3rd arg to Violation->new() must be a PPI::Element';
70 croak $msg;
71 }
59b05e08
JRT
72 }
73
74 #Create object
59b05e08
JRT
75 my $self = bless {}, $class;
76 $self->{_description} = $desc;
77 $self->{_explanation} = $expl;
41ca89c8 78 $self->{_severity} = $sev;
59b05e08 79 $self->{_policy} = caller;
6bf9b465
JRT
80 $self->{_location} = $elem->location() || [0,0];
81
82 my $stmnt = $elem->statement() || $elem;
55ae7242 83 $self->{_source} = $stmnt->content() || $EMPTY;
6bf9b465 84
59b05e08
JRT
85
86 return $self;
87}
88
55ae7242
JRT
89#-----------------------------------------------------------------------------
90
91sub set_format { return $FORMAT = $_[0]; }
92sub get_format { return $FORMAT; }
93
94#-----------------------------------------------------------------------------
7e86d49a
JRT
95
96sub sort_by_location {
660ada00
JRT
97
98 ref $_[0] || shift; #Can call as object or class method
99 return scalar @_ if ! wantarray; #In case we are called in scalar context
100
101 ## no critic qw(RequireSimpleSort);
102 ## TODO: What if $a and $b are not Violation objects?
6bf9b465 103 return sort { (($a->location->[0] || 0) <=> ($b->location->[0] || 0))
660ada00 104 || (($a->location->[1] || 0) <=> ($b->location->[1] || 0)) } @_;
7e86d49a
JRT
105}
106
55ae7242 107#-----------------------------------------------------------------------------
59b05e08 108
7e86d49a 109sub sort_by_severity {
660ada00
JRT
110
111 ref $_[0] || shift; #Can call as object or class method
112 return scalar @_ if ! wantarray; #In case we are called in scalar context
113
114 ## no critic qw(RequireSimpleSort);
115 ## TODO: What if $a and $b are not Violation objects?
10a6704d 116 return sort { ($a->severity() || 0) <=> ($b->severity() || 0) } @_;
bf159007
JRT
117}
118
55ae7242 119#-----------------------------------------------------------------------------
bf159007 120
7e86d49a 121sub location {
59b05e08
JRT
122 my $self = shift;
123 return $self->{_location};
124}
125
55ae7242 126#-----------------------------------------------------------------------------
59b05e08 127
41ca89c8 128sub diagnostics {
59b05e08
JRT
129 my $self = shift;
130 my $pol = $self->policy();
131 return $DIAGNOSTICS{$pol};
132}
133
55ae7242 134#-----------------------------------------------------------------------------
59b05e08 135
41ca89c8
JRT
136sub description {
137 my $self = shift;
59b05e08
JRT
138 return $self->{_description};
139}
140
55ae7242 141#-----------------------------------------------------------------------------
59b05e08 142
41ca89c8 143sub explanation {
59b05e08
JRT
144 my $self = shift;
145 my $expl = $self->{_explanation};
146 if( ref $expl eq 'ARRAY' ) {
0a6f07d0
AL
147 my $page = @{$expl} > 1 ? 'pages' : 'page';
148 $page .= $SPACE . join $COMMA, @{$expl};
149 $expl = "See $page of PBP";
59b05e08
JRT
150 }
151 return $expl;
152}
153
55ae7242 154#-----------------------------------------------------------------------------
59b05e08 155
41ca89c8
JRT
156sub severity {
157 my $self = shift;
158 return $self->{_severity};
159}
160
55ae7242 161#-----------------------------------------------------------------------------
41ca89c8
JRT
162
163sub policy {
59b05e08
JRT
164 my $self = shift;
165 return $self->{_policy};
166}
167
55ae7242 168#-----------------------------------------------------------------------------
59b05e08 169
6bf9b465
JRT
170sub source {
171 my $self = shift;
172 my $source = $self->{_source};
de0e06e0 173 #Return the first line of code only.
6bf9b465
JRT
174 $source =~ m{\A ( [^\n]* ) }mx;
175 return $1;
176}
177
55ae7242 178#-----------------------------------------------------------------------------
6bf9b465 179
59b05e08
JRT
180sub to_string {
181 my $self = shift;
a644f77b 182
eebbea43
JRT
183 my $short_policy = $self->policy();
184 $short_policy =~ s/ \A Perl::Critic::Policy:: //xms;
185
41ca89c8 186 my %fspec = (
6bf9b465
JRT
187 'l' => $self->location->[0], 'c' => $self->location->[1],
188 'm' => $self->description(), 'e' => $self->explanation(),
a644f77b 189 'P' => $self->policy(), 'd' => $self->diagnostics(),
6bf9b465 190 's' => $self->severity(), 'r' => $self->source(),
a644f77b 191 'p' => $short_policy,
59b05e08
JRT
192 );
193 return stringf($FORMAT, %fspec);
194}
195
55ae7242 196#-----------------------------------------------------------------------------
f731cec9
JRT
197# Apparently, some perls do not implicitly stringify overloading
198# objects before doing a comparison. This causes a couple of our
199# sorting tests to fail. To work around this, we overload C<cmp> to
200# do it explicitly.
eebbea43
JRT
201#
202# 20060503 - More information: This problem has been traced to
203# Test::Simple versions <= 0.60, not perl itself. Upgrading to
204# Test::Simple v0.62 will fix the problem. But rather than forcing
205# everyone to upgrade, I have decided to leave this workaround in
206# place.
f731cec9
JRT
207
208sub _compare { return "$_[0]" cmp "$_[1]" }
209
210#-----------------------------------------------------------------------------
59b05e08
JRT
211
212sub _mod2file {
213 my $module = shift;
7e86d49a 214 $module =~ s{::}{/}mxg;
59b05e08
JRT
215 $module .= '.pm';
216 return $INC{$module} || $EMPTY;
217}
218
55ae7242 219#-----------------------------------------------------------------------------
59b05e08
JRT
220
221sub _get_diagnostics {
222
223 my $file = shift;
224
1e7b8681
JRT
225 # Extract POD into a string
226 my $pod_string = $EMPTY;
eebbea43 227 my $handle = IO::String->new( \$pod_string );
1e7b8681 228 my $parser = Pod::PlainText->new();
7e86d49a 229 $parser->select('DESCRIPTION');
eebbea43 230 $parser->parse_from_file( $file, $handle );
6bf9b465 231
55ae7242 232 # Remove header and trailing whitespace.
1e7b8681 233 $pod_string =~ s{ \A \s* DESCRIPTION \s* \n}{}mx;
55ae7242 234 $pod_string =~ s{ \s* \z}{}mx;
1e7b8681 235 return $pod_string;
59b05e08
JRT
236}
237
2381;
239
240#----------------------------------------------------------------------------
241
242__END__
243
244=head1 NAME
245
246Perl::Critic::Violation - Represents policy violations
247
248=head1 SYNOPSIS
249
250 use PPI;
251 use Perl::Critic::Violation;
252
6d9feae6 253 my $elem = $doc->child(0); #$doc is a PPI::Document object
59b05e08 254 my $desc = 'Offending code'; #Describe the violation
b2c7354a 255 my $expl = [1,45,67]; #Page numbers from PBP
6d9feae6
JRT
256 my $sev = 5; #Severity level of this violation
257
258 my $vio = Perl::Critic::Violation->new($desc, $expl, $node, $sev);
59b05e08
JRT
259
260=head1 DESCRIPTION
261
b2c7354a 262Perl::Critic::Violation is the generic representation of an individual
59b05e08
JRT
263Policy violation. Its primary purpose is to provide an abstraction
264layer so that clients of L<Perl::Critic> don't have to know anything
265about L<PPI>. The C<violations> method of all L<Perl::Critic::Policy>
266subclasses must return a list of these Perl::Critic::Violation
267objects.
268
269=head1 CONSTRUCTOR
270
271=over 8
272
6d9feae6 273=item C<new( $description, $explanation, $element, $severity )>
59b05e08 274
b2c7354a 275Returns a reference to a new C<Perl::Critic::Violation> object. The
59b05e08
JRT
276arguments are a description of the violation (as string), an
277explanation for the policy (as string) or a series of page numbers in
b2c7354a 278PBP (as an ARRAY ref), a reference to the L<PPI> element that caused
6d9feae6 279the violation, and the severity of the violation (as an integer).
59b05e08
JRT
280
281=back
282
283=head1 METHODS
284
285=over 8
286
6d9feae6 287=item C<description()>
59b05e08 288
b2c7354a 289Returns a brief description of the policy that has been violated as a string.
59b05e08 290
6d9feae6 291=item C<explanation()>
59b05e08 292
0a5a3bc9 293Returns an explanation of the policy as a string or as reference to
b2c7354a 294an array of page numbers in PBP.
59b05e08 295
6d9feae6 296=item C<location()>
59b05e08 297
0a5a3bc9
JRT
298Returns a two-element list containing the line and column number where
299this Violation occurred.
300
6d9feae6 301=item C<severity()>
0a5a3bc9
JRT
302
303Returns the severity of this Violation as an integer ranging from 1 to
3045, where 5 is the "most" severe.
59b05e08 305
6d9feae6 306=item C<sort_by_severity( @violation_objects )>
7e86d49a
JRT
307
308If you need to sort Violations by severity, use this handy routine:
309
310 @sorted = Perl::Critic::Violation::sort_by_severity(@violations);
311
6d9feae6 312=item C<sort_by_location( @violation_objects )>
bf159007
JRT
313
314If you need to sort Violations by location, use this handy routine:
315
7e86d49a 316 @sorted = Perl::Critic::Violation::sort_by_location(@violations);
bf159007 317
6d9feae6 318=item C<diagnostics()>
59b05e08 319
6d9feae6
JRT
320Returns a formatted string containing a full discussion of the
321motivation for and details of the Policy module that created this
322Violation. This information is automatically extracted from the
323C<DESCRIPTION> section of the Policy module's POD.
59b05e08 324
6d9feae6 325=item C<policy()>
59b05e08 326
6d9feae6
JRT
327Returns the name of the L<Perl::Critic::Policy> that created this
328Violation.
6bf9b465 329
6d9feae6 330=item C<source()>
6bf9b465
JRT
331
332Returns the string of source code that caused this exception. If the
333code spans multiple lines (e.g. multi-line statements, subroutines or
334other blocks), then only the first line will be returned.
59b05e08 335
55ae7242
JRT
336=item C<set_format( $FORMAT )>
337
338Class method. Sets the format for all Violation objects when they are
339evaluated in string context. The default is C<'%d at line %l, column
340%c. %e'>. See L<"OVERLOADS"> for formatting options.
341
342=item C<get_format()>
343
344Class method. Returns the current format for all Violation objects
345when they are evaluated in string context.
346
6d9feae6 347=item C<to_string()>
59b05e08 348
b2c7354a 349Returns a string representation of this violation. The content of the
59b05e08 350string depends on the current value of the C<$FORMAT> package
6d9feae6 351variable. See L<"OVERLOADS"> for the details.
59b05e08
JRT
352
353=back
354
355=head1 FIELDS
356
357=over 8
358
6d9feae6 359=item C<$Perl::Critic::Violation::FORMAT>
59b05e08 360
55ae7242
JRT
361This variable is deprecated. Use the C<set_format> and C<get_format>
362class methods instead.
363
59b05e08
JRT
364Sets the format for all Violation objects when they are evaluated in
365string context. The default is C<'%d at line %l, column %c. %e'>.
366See L<"OVERLOADS"> for formatting options. If you want to change
6d9feae6 367C<$FORMAT>, you should probably localize it first.
59b05e08
JRT
368
369=back
370
371=head1 OVERLOADS
372
6d9feae6
JRT
373Perl::Critic::Violation overloads the C<""> operator to produce neat
374little messages when evaluated in string context. The format depends
375on the current value of the C<$FORMAT> package variable.
59b05e08
JRT
376
377Formats are a combination of literal and escape characters similar to
378the way C<sprintf> works. If you want to know the specific formatting
379capabilities, look at L<String::Format>. Valid escape characters are:
380
381 Escape Meaning
6d9feae6 382 ------- -----------------------------------------------------------------
59b05e08 383 %m Brief description of the violation
6bf9b465
JRT
384 %f Name of the file where the violation occurred.
385 %l Line number where the violation occurred
386 %c Column number where the violation occurred
59b05e08
JRT
387 %e Explanation of violation or page numbers in PBP
388 %d Full diagnostic discussion of the violation
6bf9b465 389 %r The string of source code that caused the violation
a644f77b
CD
390 %P Name of the Policy module that created the violation
391 %p Name of the Policy without the Perl::Critic::Policy:: prefix
6bf9b465 392 %s The severity level of the violation
59b05e08
JRT
393
394Here are some examples:
b78c2626 395
6bf9b465 396 $Perl::Critic::Violation::FORMAT = "%m at line %l, column %c.\n";
59b05e08
JRT
397 #looks like "Mixed case variable name at line 6, column 23."
398
6bf9b465
JRT
399 $Perl::Critic::Violation::FORMAT = "%m near '%r'\n";
400 #looks like "Mixed case variable name near 'my $theGreatAnswer = 42;'"
401
402 $Perl::Critic::Violation::FORMAT = "%l:%c:%p\n";
59b05e08
JRT
403 #looks like "6:23:NamingConventions::ProhibitMixedCaseVars"
404
6bf9b465 405 $Perl::Critic::Violation::FORMAT = "%m at line %l. %e. \n%d\n";
59b05e08
JRT
406 #looks like "Mixed case variable name at line 6. See page 44 of PBP.
407 Conway's recommended naming convention is to use lower-case words
408 separated by underscores. Well-recognized acronyms can be in ALL
6bf9b465 409 CAPS, but must be separated by underscores from other parts of the
59b05e08
JRT
410 name."
411
412=head1 AUTHOR
413
414Jeffrey Ryan Thalhammer <thaljef@cpan.org>
415
416=head1 COPYRIGHT
417
c3c88e54 418Copyright (c) 2005-2006 Jeffrey Ryan Thalhammer. All rights reserved.
59b05e08
JRT
419
420This program is free software; you can redistribute it and/or modify
421it under the same terms as Perl itself. The full text of this license
422can be found in the LICENSE file included with this module.
423
424=cut