view release on metacpan or  search on metacpan

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

use String::Format qw< stringf >;

use overload ( q{""} => 'to_string', cmp => '_compare' );

use Perl::Critic::Utils qw< :characters :internal_lookup >;
use Perl::Critic::Utils::POD qw<
    get_pod_section_for_module
    trim_pod_section
>;
use Perl::Critic::Exception::Fatal::Internal qw< throw_internal >;

our $VERSION = '1.108';


Readonly::Scalar my $LOCATION_LINE_NUMBER               => 0;
Readonly::Scalar my $LOCATION_COLUMN_NUMBER             => 1;
Readonly::Scalar my $LOCATION_VISUAL_COLUMN_NUMBER      => 2;
Readonly::Scalar my $LOCATION_LOGICAL_LINE_NUMBER       => 3;
Readonly::Scalar my $LOCATION_LOGICAL_FILENAME          => 4;


# Class variables...
my $format = "%m at line %l, column %c. %e.\n"; # Default stringy format
my %diagnostics = ();  # Cache of diagnostic messages

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

Readonly::Scalar my $CONSTRUCTOR_ARG_COUNT => 5;

sub new {
    my ( $class, $desc, $expl, $elem, $sev ) = @_;

    # Check arguments to help out developers who might
    # be creating new Perl::Critic::Policy modules.

    if ( @_ != $CONSTRUCTOR_ARG_COUNT ) {
        throw_internal 'Wrong number of args to Violation->new()';
    }

    if ( eval { $elem->isa( 'Perl::Critic::Document' ) } ) {
        # break the facade, return the real PPI::Document
        $elem = $elem->ppi_document();
    }

    if ( not eval { $elem->isa( 'PPI::Element' ) } ) {
        throw_internal '3rd arg to Violation->new() must be a PPI::Element';
    }

    # Strip punctuation.  These are controlled by the user via the
    # formats.  He/She can use whatever makes sense to them.
    ($desc, $expl) = _chomp_periods($desc, $expl);

    # Create object
    my $self = bless {}, $class;
    $self->{_description} = $desc;
    $self->{_explanation} = $expl;
    $self->{_severity}    = $sev;
    $self->{_policy}      = caller;
    $self->{_elem}        = $elem;

    # Do these now before the weakened $doc gets garbage collected
    my $top = $elem->top();
    $self->{_filename} = $top->can('filename') ? $top->filename() : undef;
    $self->{_source}   = _first_line_of_source( $elem );
    $self->{_location} =
        $elem->location() || [ 0, 0, 0, 0, $self->filename() ];

    return $self;
}

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

sub set_format { return $format = verbosity_to_format( $_[0] ); }  ## no critic(ArgUnpacking)
sub get_format { return $format;         }

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

sub sort_by_location {  ## no critic(ArgUnpacking)

    ref $_[0] || shift;              # Can call as object or class method
    return scalar @_ if ! wantarray; # In case we are called in scalar context

    ## TODO: What if $a and $b are not Violation objects?
    return
        map {$_->[0]}
            sort { ($a->[1] <=> $b->[1]) || ($a->[2] <=> $b->[2]) }
                map {[$_, $_->location->[0] || 0, $_->location->[1] || 0]}
                    @_;
}

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

sub sort_by_severity {  ## no critic(ArgUnpacking)

    ref $_[0] || shift;              # Can call as object or class method
    return scalar @_ if ! wantarray; # In case we are called in scalar context

    ## TODO: What if $a and $b are not Violation objects?
    return
        map {$_->[0]}
            sort { $a->[1] <=> $b->[1] }
                map {[$_, $_->severity() || 0]}
                    @_;
}

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

sub location {
    my $self = shift;

    return $self->{_location};
}

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

sub line_number {
    my ($self) = @_;

    return $self->location()->[$LOCATION_LINE_NUMBER];
}