vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Violation.pm

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