view release on metacpan or  search on metacpan

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

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

Readonly::Hash my %SEVERITY_NUMBER_OF => (
   gentle  => 5,
   stern   => 4,
   harsh   => 3,
   cruel   => 2,
   brutal  => 1,
);

Readonly::Array our @SEVERITY_NAMES =>  #This is exported!
    sort
        { $SEVERITY_NUMBER_OF{$a} <=> $SEVERITY_NUMBER_OF{$b} }
        keys %SEVERITY_NUMBER_OF;

sub severity_to_number {
    my ($severity) = @_;
    return _normalize_severity( $severity ) if is_integer( $severity );
    my $severity_number = $SEVERITY_NUMBER_OF{lc $severity};

    if ( not defined $severity_number ) {
        throw_generic qq{Invalid severity: "$severity"};
    }

    return $severity_number;
}

sub _normalize_severity {
    my $s = shift || return $SEVERITY_HIGHEST;
    $s = $s > $SEVERITY_HIGHEST ? $SEVERITY_HIGHEST : $s;
    $s = $s < $SEVERITY_LOWEST  ? $SEVERITY_LOWEST : $s;
    return $s;
}

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

Readonly::Array my @SKIP_DIR => qw( CVS RCS .svn _darcs {arch} .bzr .cdv .git .hg .pc _build blib );
Readonly::Hash my %SKIP_DIR => hashify( @SKIP_DIR );

sub all_perl_files {

    # Recursively searches a list of directories and returns the paths
    # to files that seem to be Perl source code.  This subroutine was
    # poached from Test::Perl::Critic.

    my @queue      = @_;
    my @code_files = ();

    while (@queue) {
        my $file = shift @queue;
        if ( -d $file ) {
            opendir my ($dh), $file or next;
            my @newfiles = sort readdir $dh;
            closedir $dh;

            @newfiles = File::Spec->no_upwards(@newfiles);
            @newfiles = grep { not $SKIP_DIR{$_} } @newfiles;
            push @queue, map { File::Spec->catfile($file, $_) } @newfiles;
        }

        if ( (-f $file) && ! _is_backup($file) && _is_perl($file) ) {
            push @code_files, $file;
        }
    }
    return @code_files;
}


#-----------------------------------------------------------------------------
# Decide if it's some sort of backup file

sub _is_backup {
    my ($file) = @_;
    return 1 if $file =~ m{ [.] swp \z}xms;
    return 1 if $file =~ m{ [.] bak \z}xms;
    return 1 if $file =~ m{  ~ \z}xms;
    return 1 if $file =~ m{ \A [#] .+ [#] \z}xms;
    return;
}

#-----------------------------------------------------------------------------
# Returns true if the argument ends with a perl-ish file
# extension, or if it has a shebang-line containing 'perl' This
# subroutine was also poached from Test::Perl::Critic

sub _is_perl {
    my ($file) = @_;

    #Check filename extensions
    return 1 if $file =~ m{ [.] PL    \z}xms;
    return 1 if $file =~ m{ [.] p[lm] \z}xms;
    return 1 if $file =~ m{ [.] t     \z}xms;

    #Check for shebang
    open my $fh, '<', $file or return;
    my $first = <$fh>;
    close $fh or throw_generic "unable to close $file: $OS_ERROR";

    return 1 if defined $first && ( $first =~ m{ \A [#]!.*perl }xms );
    return;
}

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

sub shebang_line {
    my $doc = shift;
    my $first_element = $doc->first_element();
    return if not $first_element;
    return if not $first_element->isa('PPI::Token::Comment');
    my $location = $first_element->location();
    return if !$location;
    # The shebang must be the first two characters in the file, according to
    # http://en.wikipedia.org/wiki/Shebang_(Unix)
    return if $location->[0] != 1; # line number
    return if $location->[1] != 1; # column number
    my $shebang = $first_element->content;
    return if $shebang !~ m{ \A [#]! }xms;
    return $shebang;
}

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

sub words_from_string {
    my $str = shift;

    return split q{ }, $str; # This must be a literal space, not $SPACE
}

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

sub is_unchecked_call {
    my $elem = shift;

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

this function will return just the C<$x>, not the whole expression.
This is different from the behavior of C<parse_arg_list()>.  Another
caveat is:

    int(($x + $y) + 0.5)

which returns C<($x + $y)> as a
L<PPI::Structure::List|PPI::Structure::List> instance.


=item C<parse_arg_list( $element )>

Given a L<PPI::Element|PPI::Element> that is presumed to be a function
call (which is usually a L<PPI::Token::Word|PPI::Token::Word>), splits
the argument expressions into arrays of tokens.  Returns a list
containing references to each of those arrays.  This is useful because
parentheses are optional when calling a function, and PPI parses them
very differently.  So this method is a poor-man's parse tree of PPI
nodes.  It's not bullet-proof because it doesn't respect precedence.
In general, I don't like the way this function works, so don't count
on it to be stable (or even present).


=item C<split_nodes_on_comma( @nodes )>

This has the same return type as C<parse_arg_list()> but expects to be
passed the nodes that represent the interior of a list, like:

    'foo', 1, 2, 'bar'


=item C<is_script( $document )>

B<This subroutine is deprecated and will be removed in a future release.> You
should use the L<Perl::Critic::Document/"is_program()"> method instead.


=item C<is_in_void_context( $token )>

Given a L<PPI::Token|PPI::Token>, answer whether it appears to be in a
void context.


=item C<policy_long_name( $policy_name )>

Given a policy class name in long or short form, return the long form.


=item C<policy_short_name( $policy_name )>

Given a policy class name in long or short form, return the short
form.


=item C<all_perl_files( @directories )>

Given a list of directories, recursively searches through all the
directories (depth first) and returns a list of paths for all the
files that are Perl code files.  Any administrative files for CVS or
Subversion are skipped, as are things that look like temporary or
backup files.

A Perl code file is:

=over

=item * Any file that ends in F<.PL>, F<.pl>, F<.pm>, or F<.t>

=item * Any file that has a first line with a shebang containing 'perl'

=back


=item C<severity_to_number( $severity )>

If C<$severity> is given as an integer, this function returns
C<$severity> but normalized to lie between C<$SEVERITY_LOWEST> and
C<$SEVERITY_HIGHEST>.  If C<$severity> is given as a string, this
function returns the corresponding severity number.  If the string
doesn't have a corresponding number, this function will throw an
exception.


=item C<is_valid_numeric_verbosity( $severity )>

Answers whether the argument has a translation to a Violation format.


=item C<verbosity_to_format( $verbosity_level )>

Given a verbosity level between 1 and 10, returns the corresponding
predefined format string.  These formats are suitable for passing to
the C<set_format> method in
L<Perl::Critic::Violation|Perl::Critic::Violation>.  See the
L<perlcritic|perlcritic> documentation for a listing of the predefined
formats.


=item C<hashify( @list )>

Given C<@list>, return a hash where C<@list> is in the keys and each
value is 1.  Duplicate values in C<@list> are silently squished.


=item C<interpolate( $literal )>

Given a C<$literal> string that may contain control characters (e.g..
'\t' '\n'), this function does a double interpolation on the string
and returns it as if it had been declared in double quotes.  For
example:

    'foo \t bar \n' ...becomes... "foo \t bar \n"


=item C<shebang_line( $document )>

Given a L<PPI::Document|PPI::Document>, test if it starts with C<#!>.
If so, return that line.  Otherwise return undef.


=item C<words_from_string( $str )>