view release on metacpan or  search on metacpan

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

## critic [ValuesAndExpressions::RequireInterpolationOfMetachars]
use constant supported_parameters => qw(strict_quotes ignore_quotes formats);
use constant default_severity     => $SEVERITY_MEDIUM;
use constant default_themes       => qw(logiclab);
use constant applies_to           => 'PPI::Document';

my @strip_tokens = qw(
  PPI::Token::Structure
  PPI::Token::Whitespace
);

my @parsable_tokens = qw(
  PPI::Token::Quote::Double
  PPI::Token::Quote::Single
  PPI::Token::Number::Float
  PPI::Token::Number::Version
);

sub violates {
    my ( $self, $elem, $doc ) = @_;

    my $version_spec = q{};
    my $separator;

    if ( my $stmt = $doc->find_first( \&_is_version_declaration_statement ) ) {

        my $tokenizer = PPI::Tokenizer->new( \$stmt );
        my $tokens    = $tokenizer->all_tokens;

        ( $version_spec, $separator ) = $self->_extract_version($tokens);
    }

    if ( $version_spec and $self->{_strict_quotes} and $separator ) {
        if ( $separator ne q{'} ) {
            return $self->violation( $DESC, $EXPL, $doc );
        }
    }

    if ( $version_spec and $self->{_ignore_quotes} and $separator ) {
        $version_spec =~ s/$separator//xsmg;
    }

    my $ok;

    foreach my $format ( @{ $self->{_formats} } ) {
        if ( $version_spec and $version_spec =~ m/$format/xsm ) {
            $ok++;
        }
    }

    if ( $version_spec and not $ok ) {
        return $self->violation( $DESC, $EXPL, $doc );
    }

    return;
}

sub _parse_formats {
    my ( $self, $config_string ) = @_;

    my @formats = split m{ \s* [||] \s* }xms, $config_string;

    return \@formats;
}

sub initialize_if_enabled {
    my ( $self, $config ) = @_;

    #Setting the default
    $self->{_formats} = [qw(\A\d+\.\d+(_\d+)?\z)];

    $self->{_strict_quotes} = $config->get('strict_quotes') || 0;
    $self->{_ignore_quotes} = $config->get('ignore_quotes') || 1;

    my $formats = $config->get('formats');

    if ($formats) {
        $self->{_formats} = $self->_parse_formats($formats);
    }

    return $TRUE;
}

sub _extract_version {
    my ( $self, $tokens ) = @_;

    ##stripping whitespace and structure tokens
    my $i = 0;
    foreach my $t ( @{$tokens} ) {
        if ( any { ref $t eq $_ } @strip_tokens ) {
            splice @{$tokens}, $i, 1;
        }
        $i++;
    }

    #Trying to locate and match version containing token
    foreach my $t ( @{$tokens} ) {
        if ( any { ref $t eq $_ } @parsable_tokens ) {
            if ( $t->{separator} ) {
                return ( $t->content, $t->{separator} );
            }
            else {
                return $t->content;
            }
        }
    }

    return;
}

sub _is_version_declaration_statement {    ## no critic (ArgUnpacking)
    return 1 if _is_our_version(@_);
    return 1 if _is_vars_package_version(@_);
    return 0;
}

sub _is_our_version {
    my ( undef, $elem ) = @_;
    return if not $elem;
    $elem->isa('PPI::Statement::Variable') || return 0;
    $elem->type() eq 'our' || return 0;