—

              
##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils.pm $
#     $Date: 2008-05-19 23:39:19 -0500 (Mon, 19 May 2008) $
#   $Author: clonezone $
# $Revision: 2387 $
##############################################################################
# NOTE: This module is way too large.  Please think about adding new
# functionality into a P::C::Utils::* module instead.
package Perl::Critic::Utils;
use strict;
use warnings;
use Readonly;
use File::Spec qw();
use Scalar::Util qw( blessed );
use B::Keywords qw();
use PPI::Token::Quote::Single;
use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic };
use Perl::Critic::Utils::PPI qw< is_ppi_expression_or_generic_statement >;
use base 'Exporter';
our $VERSION = '1.083_005';
#-----------------------------------------------------------------------------
# Exportable symbols here.
Readonly::Array our @EXPORT_OK => qw(
    $TRUE
    $FALSE
    $POLICY_NAMESPACE
    $SEVERITY_HIGHEST
    $SEVERITY_HIGH
    $SEVERITY_MEDIUM
    $SEVERITY_LOW
    $SEVERITY_LOWEST
    @SEVERITY_NAMES
    $DEFAULT_VERBOSITY
    $DEFAULT_VERBOSITY_WITH_FILE_NAME
    $COLON
    $COMMA
    $DQUOTE
    $EMPTY
    $FATCOMMA
    $PERIOD
    $PIPE
    $QUOTE
    $BACKTICK
    $SCOLON
    $SPACE
    $SLASH
    $BSLASH
    $LEFT_PAREN
    $RIGHT_PAREN
    all_perl_files
    find_keywords
    first_arg
    hashify
    interpolate
    is_class_name
    is_function_call
    is_hash_key
    is_in_void_context
    is_included_module_name
    is_integer
    is_label_pointer
    is_method_call
    is_package_declaration
    is_perl_bareword
    is_perl_builtin
    is_perl_builtin_with_list_context
    is_perl_builtin_with_multiple_arguments
    is_perl_builtin_with_no_arguments
    is_perl_builtin_with_one_argument
    is_perl_builtin_with_optional_argument
    is_perl_builtin_with_zero_and_or_one_arguments
    is_perl_filehandle
    is_perl_global
    is_qualified_name
    is_script
    is_subroutine_name
    is_unchecked_call
    is_valid_numeric_verbosity
    parse_arg_list
    policy_long_name
    policy_short_name
    precedence_of
    severity_to_number
    shebang_line
    split_nodes_on_comma
    verbosity_to_format
    words_from_string
);
# Note: this is deprecated.
Readonly::Array our @EXPORT => @EXPORT_OK;  ## no critic (ProhibitAutomaticExport)
Readonly::Hash our %EXPORT_TAGS => (
    all             => [ @EXPORT_OK ],
    booleans        => [ qw{ $TRUE $FALSE } ],
    severities      => [
        qw{
            $SEVERITY_HIGHEST
            $SEVERITY_HIGH
            $SEVERITY_MEDIUM
            $SEVERITY_LOW
            $SEVERITY_LOWEST
            @SEVERITY_NAMES
        }
    ],
    characters      => [
        qw{
            $COLON
            $COMMA
            $DQUOTE
            $EMPTY
            $FATCOMMA
            $PERIOD
            $PIPE
            $QUOTE
            $BACKTICK
            $SCOLON
            $SPACE
            $SLASH
            $BSLASH
            $LEFT_PAREN
            $RIGHT_PAREN
        }
    ],
    classification  => [
        qw{
            is_class_name
            is_function_call
            is_hash_key
            is_included_module_name
            is_integer
            is_label_pointer
            is_method_call
            is_package_declaration
            is_perl_bareword
            is_perl_builtin
            is_perl_filehandle
            is_perl_global
            is_perl_builtin_with_list_context
            is_perl_builtin_with_multiple_arguments
            is_perl_builtin_with_no_arguments
            is_perl_builtin_with_one_argument
            is_perl_builtin_with_optional_argument
            is_perl_builtin_with_zero_and_or_one_arguments
            is_qualified_name
            is_script
            is_subroutine_name
            is_unchecked_call
            is_valid_numeric_verbosity
        }
    ],
    data_conversion => [ qw{ hashify words_from_string interpolate } ],
    ppi             => [ qw{ first_arg parse_arg_list } ],
    internal_lookup => [ qw{ severity_to_number verbosity_to_format } ],
    language        => [ qw{ precedence_of } ],
    deprecated      => [ qw{ find_keywords } ],
);
#-----------------------------------------------------------------------------
Readonly::Scalar our $POLICY_NAMESPACE => 'Perl::Critic::Policy';
#-----------------------------------------------------------------------------
Readonly::Scalar our $SEVERITY_HIGHEST => 5;
Readonly::Scalar our $SEVERITY_HIGH    => 4;
Readonly::Scalar our $SEVERITY_MEDIUM  => 3;
Readonly::Scalar our $SEVERITY_LOW     => 2;
Readonly::Scalar our $SEVERITY_LOWEST  => 1;
#-----------------------------------------------------------------------------
Readonly::Scalar our $COMMA        => q{,};
Readonly::Scalar our $FATCOMMA     => q{=>};
Readonly::Scalar our $COLON        => q{:};
Readonly::Scalar our $SCOLON       => q{;};
Readonly::Scalar our $QUOTE        => q{'};
Readonly::Scalar our $DQUOTE       => q{"};
Readonly::Scalar our $BACKTICK     => q{`};
Readonly::Scalar our $PERIOD       => q{.};
Readonly::Scalar our $PIPE         => q{|};
Readonly::Scalar our $SPACE        => q{ };
Readonly::Scalar our $SLASH        => q{/};
Readonly::Scalar our $BSLASH       => q{\\};
Readonly::Scalar our $LEFT_PAREN   => q{(};
Readonly::Scalar our $RIGHT_PAREN  => q{)};
Readonly::Scalar our $EMPTY        => q{};
Readonly::Scalar our $TRUE         => 1;
Readonly::Scalar our $FALSE        => 0;
#-----------------------------------------------------------------------------
#TODO: Should this include punctuations vars?
#-----------------------------------------------------------------------------
## no critic (ProhibitNoisyQuotes);
Readonly::Hash my %PRECEDENCE_OF => (
  '->'  => 1,       '<'    => 10,      '//'  => 15,     '.='  => 19,
  '++'  => 2,       '>'    => 10,      '||'  => 15,     '^='  => 19,
  '--'  => 2,       '<='   => 10,      '..'  => 16,     '<<=' => 19,
  '**'  => 3,       '>='   => 10,      '...' => 17,     '>>=' => 19,
  '!'   => 4,       'lt'   => 10,      '?'   => 18,     ','   => 20,
  '~'   => 4,       'gt'   => 10,      ':'   => 18,     '=>'  => 20,
  '\\'  => 4,       'le'   => 10,      '='   => 19,     'not' => 22,
  '=~'  => 5,       'ge'   => 10,      '+='  => 19,     'and' => 23,
  '!~'  => 5,       '=='   => 11,      '-='  => 19,     'or'  => 24,
  '*'   => 6,       '!='   => 11,      '*='  => 19,     'xor' => 24,
  '/'   => 6,       '<=>'  => 11,      '/='  => 19,
  '%'   => 6,       'eq'   => 11,      '%='  => 19,
  'x'   => 6,       'ne'   => 11,      '||=' => 19,
  '+'   => 7,       'cmp'  => 11,      '&&=' => 19,
  '-'   => 7,       '&'    => 12,      '|='  => 19,
  '.'   => 7,       '|'    => 13,      '&='  => 19,
  '<<'  => 8,       '^'    => 13,      '**=' => 19,
  '>>'  => 8,       '&&'   => 14,      'x='  => 19,
);
## use critic
#-----------------------------------------------------------------------------
sub hashify {  ##no critic(ArgUnpacking)
    return map { $_ => 1 } @_;
}
#-----------------------------------------------------------------------------
sub interpolate {
    my ( $literal ) = @_;
    return eval "\"$literal\"";  ## no critic 'StringyEval';
}
#-----------------------------------------------------------------------------
sub find_keywords {
    my ( $doc, $keyword ) = @_;
    my $nodes_ref = $doc->find('PPI::Token::Word');
    return if !$nodes_ref;
    my @matches = grep { $_ eq $keyword } @{$nodes_ref};
    return @matches ? \@matches : undef;
}
#-----------------------------------------------------------------------------
sub _name_for_sub_or_stringified_element {
    my $elem = shift;
    if ( blessed $elem and $elem->isa('PPI::Statement::Sub') ) {
        return $elem->name();
    }
    return "$elem";
}
#-----------------------------------------------------------------------------
## no critic (ProhibitPackageVars)
Readonly::Hash my %BUILTINS => hashify( @B::Keywords::Functions );
sub is_perl_builtin {
    my $elem = shift;
    return if !$elem;
    return exists $BUILTINS{ _name_for_sub_or_stringified_element($elem) };
}
#-----------------------------------------------------------------------------
Readonly::Hash my %BAREWORDS => hashify( @B::Keywords::Barewords );
sub is_perl_bareword {
    my $elem = shift;
    return if !$elem;
    return exists $BAREWORDS{ _name_for_sub_or_stringified_element($elem) };
}
#-----------------------------------------------------------------------------
sub _build_globals_without_sigils {
    my @globals = map { substr $_, 1 }  @B::Keywords::Arrays,
                                        @B::Keywords::Hashes,
                                        @B::Keywords::Scalars;
    # Not all of these have sigils
    foreach my $filehandle (@B::Keywords::Filehandles) {
        (my $stripped = $filehandle) =~ s< \A [*] ><>xms;
        push @globals, $stripped;
    }
    return @globals;
}
Readonly::Array my @GLOBALS_WITHOUT_SIGILS => _build_globals_without_sigils();
Readonly::Hash my %GLOBALS => hashify( @GLOBALS_WITHOUT_SIGILS );
sub is_perl_global {
    my $elem = shift;
    return if !$elem;
    my $var_name = "$elem"; #Convert Token::Symbol to string
    $var_name =~ s{\A [\$@%*] }{}mx;  #Chop off the sigil
    return exists $GLOBALS{ $var_name };
}
#-----------------------------------------------------------------------------
Readonly::Hash my %FILEHANDLES => hashify( @B::Keywords::Filehandles );
sub is_perl_filehandle {
    my $elem = shift;
    return if !$elem;
    return exists $FILEHANDLES{ _name_for_sub_or_stringified_element($elem) };
}
## use critic
#-----------------------------------------------------------------------------
# egrep '=item.*LIST' perlfunc.pod
Readonly::Hash my %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT =>
    hashify(
        qw{
            chmod
            chown
            die
            exec
            formline
            grep
            import
            join
            kill
            map
            no
            open
            pack
            print
            printf
            push
            reverse
            say
            sort
            splice
            sprintf
            syscall
            system
            tie
            unlink
            unshift
            use
            utime
            warn
        },
    );
sub is_perl_builtin_with_list_context {
    my $elem = shift;
    return
        exists
            $BUILTINS_WHICH_PROVIDE_LIST_CONTEXT{
                _name_for_sub_or_stringified_element($elem)
            };
}
#-----------------------------------------------------------------------------
# egrep '=item.*[A-Z],' perlfunc.pod
Readonly::Hash my %BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS =>
    hashify(
        qw{
            accept
            atan2
            bind
            binmode
            bless
            connect
            crypt
            dbmopen
            fcntl
            flock
            gethostbyaddr
            getnetbyaddr
            getpriority
            getservbyname
            getservbyport
            getsockopt
            index
            ioctl
            link
            listen
            mkdir
            msgctl
            msgget
            msgrcv
            msgsnd
            open
            opendir
            pipe
            read
            recv
            rename
            rindex
            seek
            seekdir
            select
            semctl
            semget
            semop
            send
            setpgrp
            setpriority
            setsockopt
            shmctl
            shmget
            shmread
            shmwrite
            shutdown
            socket
            socketpair
            splice
            split
            substr
            symlink
            sysopen
            sysread
            sysseek
            syswrite
            truncate
            unpack
            vec
            waitpid
        },
        keys %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT
    );
sub is_perl_builtin_with_multiple_arguments {
    my $elem = shift;
    return
        exists
            $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{
                _name_for_sub_or_stringified_element($elem)
            };
}
#-----------------------------------------------------------------------------
Readonly::Hash my %BUILTINS_WHICH_TAKE_NO_ARGUMENTS =>
    hashify(
        qw{
            endgrent
            endhostent
            endnetent
            endprotoent
            endpwent
            endservent
            fork
            format
            getgrent
            gethostent
            getlogin
            getnetent
            getppid
            getprotoent
            getpwent
            getservent
            setgrent
            setpwent
            split
            time
            times
            wait
            wantarray
        }
    );
sub is_perl_builtin_with_no_arguments {
    my $elem = shift;
    return
        exists
            $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{
                _name_for_sub_or_stringified_element($elem)
            };
}
#-----------------------------------------------------------------------------
Readonly::Hash my %BUILTINS_WHICH_TAKE_ONE_ARGUMENT =>
    hashify(
        qw{
            closedir
            dbmclose
            delete
            each
            exists
            fileno
            getgrgid
            getgrnam
            gethostbyname
            getnetbyname
            getpeername
            getpgrp
            getprotobyname
            getprotobynumber
            getpwnam
            getpwuid
            getsockname
            goto
            keys
            local
            prototype
            readdir
            readline
            readpipe
            rewinddir
            scalar
            sethostent
            setnetent
            setprotoent
            setservent
            telldir
            tied
            untie
            values
        }
    );
sub is_perl_builtin_with_one_argument {
    my $elem = shift;
    return
        exists
            $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{
                _name_for_sub_or_stringified_element($elem)
            };
}
#-----------------------------------------------------------------------------
## no critic (ProhibitPackageVars)
Readonly::Hash my %BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT =>
    hashify(
        grep { not exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $_ } }
        grep { not exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $_ } }
        grep { not exists $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{ $_ } }
        @B::Keywords::Functions
    );
## use critic
sub is_perl_builtin_with_optional_argument {
    my $elem = shift;
    return
        exists
            $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{
                _name_for_sub_or_stringified_element($elem)
            };
}
#-----------------------------------------------------------------------------
sub is_perl_builtin_with_zero_and_or_one_arguments {
    my $elem = shift;
    return if not $elem;
    my $name = _name_for_sub_or_stringified_element($elem);
    return (
            exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $name }
        or  exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $name }
        or  exists $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{ $name }
    );
}
#-----------------------------------------------------------------------------
sub is_qualified_name {
    my $name = shift;
    return if not $name;
    return index ( $name, q{::} ) >= 0;
}
#-----------------------------------------------------------------------------
sub precedence_of {
    my $elem = shift;
    return if !$elem;
    return $PRECEDENCE_OF{ ref $elem ? "$elem" : $elem };
}
#-----------------------------------------------------------------------------
sub is_hash_key {
    my $elem = shift;
    return if !$elem;
    #If followed by an argument list, then its a function call, not a literal
    return if _is_followed_by_parens($elem);
    #Check curly-brace style: $hash{foo} = bar;
    my $parent = $elem->parent();
    return if !$parent;
    my $grandparent = $parent->parent();
    return if !$grandparent;
    return 1 if $grandparent->isa('PPI::Structure::Subscript');
    #Check declarative style: %hash = (foo => bar);
    my $sib = $elem->snext_sibling();
    return if !$sib;
    return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>';
    return;
}
#-----------------------------------------------------------------------------
sub _is_followed_by_parens {
    my $elem = shift;
    return if !$elem;
    my $sibling = $elem->snext_sibling() || return;
    return $sibling->isa('PPI::Structure::List');
}
#-----------------------------------------------------------------------------
sub is_included_module_name {
    my $elem  = shift;
    return if !$elem;
    my $stmnt = $elem->statement();
    return if !$stmnt;
    return if !$stmnt->isa('PPI::Statement::Include');
    return $stmnt->schild(1) == $elem;
}
#-----------------------------------------------------------------------------
sub is_integer {
    my ($value) = @_;
    return 0 if not defined $value;
    return $value =~ m{ \A [+-]? \d+ \z }mx;
}
#-----------------------------------------------------------------------------
sub is_label_pointer {
    my $elem = shift;
    return if !$elem;
    my $statement = $elem->statement();
    return if !$statement;
    my $psib = $elem->sprevious_sibling();
    return if !$psib;
    return $statement->isa('PPI::Statement::Break')
        && $psib =~ m/(?:redo|goto|next|last)/mxo;
}
#-----------------------------------------------------------------------------
sub is_method_call {
    my $elem = shift;
    return if !$elem;
    return _is_dereference_operator( $elem->sprevious_sibling() );
}
#-----------------------------------------------------------------------------
sub is_class_name {
    my $elem = shift;
    return if !$elem;
    return _is_dereference_operator( $elem->snext_sibling() )
        && !_is_dereference_operator( $elem->sprevious_sibling() );
}
#-----------------------------------------------------------------------------
sub _is_dereference_operator {
    my $elem = shift;
    return if !$elem;
    return $elem->isa('PPI::Token::Operator') && $elem eq q{->};
}
#-----------------------------------------------------------------------------
sub is_package_declaration {
    my $elem  = shift;
    return if !$elem;
    my $stmnt = $elem->statement();
    return if !$stmnt;
    return if !$stmnt->isa('PPI::Statement::Package');
    return $stmnt->schild(1) == $elem;
}
#-----------------------------------------------------------------------------
sub is_subroutine_name {
    my $elem  = shift;
    return if !$elem;
    my $sib   = $elem->sprevious_sibling();
    return if !$sib;
    my $stmnt = $elem->statement();
    return if !$stmnt;
    return $stmnt->isa('PPI::Statement::Sub') && $sib eq 'sub';
}
#-----------------------------------------------------------------------------
sub is_function_call {
    my $elem  = shift;
    return if !$elem;
    return if is_hash_key($elem);
    return if is_method_call($elem);
    return if is_class_name($elem);
    return if is_subroutine_name($elem);
    return if is_included_module_name($elem);
    return if is_package_declaration($elem);
    return if is_perl_bareword($elem);
    return if is_perl_filehandle($elem);
    return if is_label_pointer($elem);
    return 1;
}
#-----------------------------------------------------------------------------
sub is_script {
    my $doc = shift;
    return shebang_line($doc) ? 1 : 0;
}
#-----------------------------------------------------------------------------
sub is_in_void_context {
    my ($token) = @_;
    # If part of a collective, can't be void.
    return if $token->sprevious_sibling();
    my $parent = $token->statement()->parent();
    if ($parent) {
        return if $parent->isa('PPI::Structure::List');
        return if $parent->isa('PPI::Structure::ForLoop');
        return if $parent->isa('PPI::Structure::Condition');
        return if $parent->isa('PPI::Structure::Constructor');
        my $grand_parent = $parent->parent();
        if ($grand_parent) {
            return if
                    $parent->isa('PPI::Structure::Block')
                and not $grand_parent->isa('PPI::Statement::Compound');
        }
    }
    return $TRUE;
}
#-----------------------------------------------------------------------------
sub policy_long_name {
    my ( $policy_name ) = @_;
    if ( $policy_name !~ m{ \A $POLICY_NAMESPACE }mx ) {
        $policy_name = $POLICY_NAMESPACE . q{::} . $policy_name;
    }
    return $policy_name;
}
#-----------------------------------------------------------------------------
sub policy_short_name {
    my ( $policy_name ) = @_;
    $policy_name =~ s{\A $POLICY_NAMESPACE ::}{}mx;
    return $policy_name;
}
#-----------------------------------------------------------------------------
sub first_arg {
    my $elem = shift;
    my $sib  = $elem->snext_sibling();
    return if !$sib;
    if ( $sib->isa('PPI::Structure::List') ) {
        my $expr = $sib->schild(0);
        return if !$expr;
        return $expr->isa('PPI::Statement') ? $expr->schild(0) : $expr;
    }
    return $sib;
}
#-----------------------------------------------------------------------------
sub parse_arg_list {
    my $elem = shift;
    my $sib  = $elem->snext_sibling();
    return if !$sib;
    if ( $sib->isa('PPI::Structure::List') ) {
        #Pull siblings from list
        my @list_contents = $sib->schildren();
        return if not @list_contents;
        my @list_expressions;
        foreach my $item (@list_contents) {
            if (
                is_ppi_expression_or_generic_statement($item)
            ) {
                push
                    @list_expressions,
                    split_nodes_on_comma( $item->schildren() );
            }
            else {
                push @list_expressions, $item;
            }
        }
        return @list_expressions;
    }
    else {
        #Gather up remaining nodes in the statement
        my $iter     = $elem;
        my @arg_list = ();
        while ($iter = $iter->snext_sibling() ) {
            last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON;
            push @arg_list, $iter;
        }
        return split_nodes_on_comma( @arg_list );
    }
}
#---------------------------------
sub split_nodes_on_comma {
    my @nodes = @_;
    my $i = 0;
    my @node_stacks;
    for my $node (@nodes) {
        if (
                $node->isa('PPI::Token::Operator')
            and ($node eq $COMMA or $node eq $FATCOMMA)
        ) {
            if (@node_stacks) {
                $i++; #Move forward to next 'node stack'
            }
            next;
        } elsif ( $node->isa('PPI::Token::QuoteLike::Words' )) {
            my $section = $node->{sections}->[0];
            my @words = words_from_string(substr $node->content, $section->{position}, $section->{size});
            my $loc = $node->location;
            for my $word (@words) {
                my $token = PPI::Token::Quote::Single->new(q{'} . $word . q{'});
                $token->{_location} = $loc;
                push @{ $node_stacks[$i++] }, $token;
            }
            next;
        }
        push @{ $node_stacks[$i] }, $node;
    }
    return @node_stacks;
}
#-----------------------------------------------------------------------------
# XXX: You must keep the regular expressions in extras/perlcritic.el in sync
# if you change these.
Readonly::Hash my %FORMAT_OF => (
    1 => "%f:%l:%c:%m\n",
    2 => "%f: (%l:%c) %m\n",
    3 => "%m at %f line %l\n",
    4 => "%m at line %l, column %c.  %e.  (Severity: %s)\n",
    5 => "%f: %m at line %l, column %c.  %e.  (Severity: %s)\n",
    6 => "%m at line %l, near '%r'.  (Severity: %s)\n",
    7 => "%f: %m at line %l near '%r'.  (Severity: %s)\n",
    8 => "[%p] %m at line %l, column %c.  (Severity: %s)\n",
    9 => "[%p] %m at line %l, near '%r'.  (Severity: %s)\n",
   10 => "%m at line %l, column %c.\n  %p (Severity: %s)\n%d\n",
   11 => "%m at line %l, near '%r'.\n  %p (Severity: %s)\n%d\n",
);
Readonly::Scalar our $DEFAULT_VERBOSITY => 4;
Readonly::Scalar our $DEFAULT_VERBOSITY_WITH_FILE_NAME => 5;
Readonly::Scalar my $DEFAULT_FORMAT => $FORMAT_OF{$DEFAULT_VERBOSITY};
sub is_valid_numeric_verbosity {
    my ($verbosity) = @_;
    return exists $FORMAT_OF{$verbosity};
}
sub verbosity_to_format {
    my ($verbosity) = @_;
    return $DEFAULT_FORMAT if not defined $verbosity;
    return $FORMAT_OF{abs int $verbosity} || $DEFAULT_FORMAT if is_integer($verbosity);
    return interpolate( $verbosity );  #Otherwise, treat as a format spec
}
#-----------------------------------------------------------------------------
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 _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 { !$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}mx;
    return 1 if $file =~ m{ [.] bak \z}mx;
    return 1 if $file =~ m{  ~ \z}mx;
    return 1 if $file =~ m{ \A [#] .+ [#] \z}mx;
    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}mx;
    return 1 if $file =~ m{ [.] p[lm] \z}mx;
    return 1 if $file =~ m{ [.] t     \z}mx;
    #Check for shebang
    open my $fh, '<', $file or return;
    my $first = <$fh>;
    close $fh or throw_generic "unable to close $file: $!";
    return 1 if defined $first && ( $first =~ m{ \A [#]!.*perl }mx );
    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 [#]! }mx;
    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;
    return if not is_function_call( $elem );
    # check to see if there's an '=' or 'unless' or something before this.
    if( my $sib = $elem->sprevious_sibling() ){
        return if $sib;
    }
    if( my $statement = $elem->statement() ){
        # "open or die" is OK.
        # We can't check snext_sibling for 'or' since the next siblings are an
        # unknown number of arguments to the system call. Instead, check all of
        # the elements to this statement to see if we find 'or' or '||'.
        my $or_operators = sub  {
            my (undef, $elem) = @_;
            return if not $elem->isa('PPI::Token::Operator');
            return if $elem ne q{or} && $elem ne q{||};
            return 1;
        };
        return if $statement->find( $or_operators );
        if( my $parent = $elem->statement()->parent() ){
            # Check if we're in an if( open ) {good} else {bad} condition
            return if $parent->isa('PPI::Structure::Condition');
            # Return val could be captured in data structure and checked later
            return if $parent->isa('PPI::Structure::Constructor');
            # "die if not ( open() )" - It's in list context.
            if ( $parent->isa('PPI::Structure::List') ) {
                if( my $uncle = $parent->sprevious_sibling() ){
                    return if $uncle;
                }
            }
        }
    }
    return if _is_fatal($elem);
    # Otherwise, return. this system call is unchecked.
    return 1;
}
sub _is_fatal {
    my ($elem) = @_;
    my $top = $elem->top;
    return if !$top->isa('PPI::Document');
    my $includes = $top->find('PPI::Statement::Include');
    return if !$includes;
    for my $include (@{$includes}) {
        next if 'use' ne $include->type;
        if ('Fatal' eq $include->module) {
            my @args = parse_arg_list($include->schild(1));
            for my $arg (@args) {
                return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string;
            }
        } elsif ('Fatal::Exception' eq $include->module) {
            my @args = parse_arg_list($include->schild(1));
            shift @args;  # skip exception class name
            for my $arg (@args) {
                return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string;
            }
        }
    }
    return;
}
1;
__END__
HideShow 505 lines of Pod
=pod
=head1 NAME
Perl::Critic::Utils - General utility subroutines and constants for Perl::Critic and derivative distributions.
=head1 DESCRIPTION
This module provides several static subs and variables that are useful for
developing L<Perl::Critic::Policy> subclasses.  Unless you are writing Policy
modules, you probably don't care about this package.
=head1 IMPORTABLE SUBS
=over 8
=item C<find_keywords( $doc, $keyword )>
B<DEPRECATED:> Since version 0.11, every Policy is evaluated at each element
of the document.  So you shouldn't need to go looking for a particular
keyword.  If you I<do> want to use this, please import it via the
C<:deprecated> tag, rather than directly, to mark the module as needing
updating.
Given a L<PPI::Document> as C<$doc>, returns a reference to an array
containing all the L<PPI::Token::Word> elements that match C<$keyword>.  This
can be used to find any built-in function, method call, bareword, or reserved
keyword.  It will not match variables, subroutine names, literal strings,
numbers, or symbols.  If the document doesn't contain any matches, returns
undef.
=item C<is_perl_global( $element )>
Given a L<PPI::Token::Symbol> or a string, returns true if that token
represents one of the global variables provided by the L<English> module, or
one of the builtin global variables like C<%SIG>, C<%ENV>, or C<@ARGV>.  The
sigil on the symbol is ignored, so things like C<$ARGV> or C<$ENV> will still
return true.
=item C<is_perl_builtin( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a call to any of the builtin functions defined in
Perl 5.8.8.
=item C<is_perl_bareword( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a bareword (e.g. "if", "else", "sub", "package")
defined in Perl 5.8.8.
=item C<is_perl_filehandle( $element )>
Given a L<PPI::Token::Word>, or string, returns true if that token represents
one of the global filehandles (e.g. C<STDIN>, C<STDERR>, C<STDOUT>, C<ARGV>)
that are defined in Perl 5.8.8.  Note that this function will return false if
given a filehandle that is represented as a typeglob (e.g. C<*STDIN>)
=item C<is_perl_builtin_with_list_context( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a call to any of the builtin functions defined in
Perl 5.8.8 that provide a list context to the following tokens.
=item C<is_perl_builtin_with_multiple_arguments( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a call to any of the builtin functions defined in
Perl 5.8.8 that B<can> take multiple arguments.
=item C<is_perl_builtin_with_no_arguments( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a call to any of the builtin functions defined in
Perl 5.8.8 that B<cannot> take any arguments.
=item C<is_perl_builtin_with_one_argument( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a call to any of the builtin functions defined in
Perl 5.8.8 that takes B<one and only one> argument.
=item C<is_perl_builtin_with_optional_argument( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a call to any of the builtin functions defined in
Perl 5.8.8 that takes B<no more than one> argument.
The sets of values for which C<is_perl_builtin_with_multiple_arguments()>,
C<is_perl_builtin_with_no_arguments()>,
C<is_perl_builtin_with_one_argument()>, and
C<is_perl_builtin_with_optional_argument()> return true are disjoint and
their union is precisely the set of values that C<is_perl_builtin()> will
return true for.
=item C<is_perl_builtin_with_zero_and_or_one_arguments( $element )>
Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
if that token represents a call to any of the builtin functions defined in
Perl 5.8.8 that takes no and/or one argument.
Returns true if any of C<is_perl_builtin_with_no_arguments()>,
C<is_perl_builtin_with_one_argument()>, and
C<is_perl_builtin_with_optional_argument()> returns true.
=item C<is_qualified_name( $name )>
Given a string, L<PPI::Token::Word>, or L<PPI::Token::Symbol>, answers
whether it has a module component, i.e. contains "::".
=item C<precedence_of( $element )>
Given a L<PPI::Token::Operator> or a string, returns the precedence of the
operator, where 1 is the highest precedence.  Returns undef if the precedence
can't be determined (which is usually because it is not an operator).
=item C<is_hash_key( $element )>
Given a L<PPI::Element>, returns true if the element is a literal hash key.
PPI doesn't distinguish between regular barewords (like keywords or subroutine
calls) and barewords in hash subscripts (which are considered literal).  So
this subroutine is useful if your Policy is searching for L<PPI::Token::Word>
elements and you want to filter out the hash subscript variety.  In both of
the following examples, "foo" is considered a hash key:
  $hash1{foo} = 1;
  %hash2 = (foo => 1);
But if the bareword is followed by an argument list, then perl treats it as a
function call.  So in these examples, "foo" is B<not> considered a hash key:
  $hash1{ foo() } = 1;
  &hash2 = (foo() => 1);
=item C<is_included_module_name( $element )>
Given a L<PPI::Token::Word>, returns true if the element is the name of a
module that is being included via C<use>, C<require>, or C<no>.
=item C<is_integer( $value )>
Answers whether the parameter, as a string, looks like an integral value.
=item C<is_class_name( $element )>
Given a L<PPI::Token::Word>, returns true if the element that immediately
follows this element is the dereference operator "->". When a bareword has a
"->" on the B<right> side, it usually means that it is the name of the class
(from which a method is being called).
=item C<is_label_pointer( $element )>
Given a L<PPI::Token::Word>, returns true if the element is the label
in a C<next>, C<last>, C<redo>, or C<goto> statement.  Note this is not the
same thing as the label declaration.
=item C<is_method_call( $element )>
Given a L<PPI::Token::Word>, returns true if the element that immediately
precedes this element is the dereference operator "->". When a bareword has a
"->" on the B<left> side, it usually means that it is the name of a method
(that is being called from a class).
=item C<is_package_declaration( $element )>
Given a L<PPI::Token::Word>, returns true if the element is the name of a
package that is being declared.
=item C<is_subroutine_name( $element )>
Given a L<PPI::Token::Word>, returns true if the element is the name of a
subroutine declaration.  This is useful for distinguishing barewords and from
function calls from subroutine declarations.
=item C<is_function_call( $element )>
Given a L<PPI::Token::Word> returns true if the element appears to be call to
a static function.  Specifically, this function returns true if
C<is_hash_key>, C<is_method_call>, C<is_subroutine_name>,
C<is_included_module_anme>, C<is_package_declaration>, C<is_perl_bareword>,
C<is_perl_filehandle>, C<is_label_pointer> and C<is_subroutine_name> all
return false for the given element.
=item C<first_arg( $element )>
Given a L<PPI::Element> that is presumed to be a function call (which is
usually a L<PPI::Token::Word>), return the first argument.  This is similar of
C<parse_arg_list()> and follows the same logic.  Note that for the code:
  int($x + 0.5)
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> instance.
=item C<parse_arg_list( $element )>
Given a L<PPI::Element> that is presumed to be a function call (which is
usually a L<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 )>
Given a L<PPI::Document>, test if it starts with C</#!.*/>.  If so, it is
judged to be a script instead of a module.  See C<shebang_line()>.
=item C<is_in_void_context( $token )>
Given a L<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 4
=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>.  See the L<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>, test if it starts with C<#!>.  If so, return that
line.  Otherwise return undef.
=item C<words_from_string( $str )>
Given config string I<$str>, return all the words from the string.  This is
safer than splitting on whitespace.
=item C<is_unchecked_call( $element )>
Given a L<PPI::Element>, test to see if it contains a function call whose
return value is not checked.
=back
=head1 IMPORTABLE VARIABLES
=over 8
=item C<$COMMA>
=item C<$FATCOMMA>
=item C<$COLON>
=item C<$SCOLON>
=item C<$QUOTE>
=item C<$DQUOTE>
=item C<$BACKTICK>
=item C<$PERIOD>
=item C<$PIPE>
=item C<$EMPTY>
=item C<$SPACE>
=item C<$SLASH>
=item C<$BSLASH>
=item C<$LEFT_PAREN>
=item C<$RIGHT_PAREN>
These character constants give clear names to commonly-used strings that can
be hard to read when surrounded by quotes and other punctuation.  Can be
imported in one go via the C<:characters> tag.
=item C<$SEVERITY_HIGHEST>
=item C<$SEVERITY_HIGH>
=item C<$SEVERITY_MEDIUM>
=item C<$SEVERITY_LOW>
=item C<$SEVERITY_LOWEST>
These numeric constants define the relative severity of violating each
L<Perl::Critic::Policy>.  The C<get_severity> and C<default_severity> methods
of every Policy subclass must return one of these values. Can be imported via
the C<:severities> tag.
=item C<$DEFAULT_VERBOSITY>
The default numeric verbosity.
=item C<$DEFAULT_VERBOSITY_WITH_FILE_NAME>
The numeric verbosity that corresponds to the format indicated by
C<$DEFAULT_VERBOSITY>, but with the file name prefixed to it.
=item C<$TRUE>
=item C<$FALSE>
These are simple booleans. 1 and 0 respectively.  Be mindful of using these
with string equality.  C<$FALSE ne $EMPTY>.  Can be imported via the
C<:booleans> tag.
=back
=head1 IMPORT TAGS
The following groups of functions and constants are available as parameters to
a C<use Perl::Critic::Util> statement.
=over
=item C<:all>
The lot.
=item C<:booleans>
Includes:
C<$TRUE>, C<$FALSE>
=item C<:severities>
Includes:
C<$SEVERITY_HIGHEST>,
C<$SEVERITY_HIGH>,
C<$SEVERITY_MEDIUM>,
C<$SEVERITY_LOW>,
C<$SEVERITY_LOWEST>,
C<@SEVERITY_NAMES>
=item C<:characters>
Includes:
C<$COLON>,
C<$COMMA>,
C<$DQUOTE>,
C<$EMPTY>,
C<$FATCOMMA>,
C<$PERIOD>,
C<$PIPE>,
C<$QUOTE>,
C<$BACKTICK>,
C<$SCOLON>,
C<$SPACE>,
C<$SLASH>,
C<$BSLASH>
C<$LEFT_PAREN>
C<$RIGHT_PAREN>
=item C<:classification>
Includes:
C<is_function_call>,
C<is_hash_key>,
C<is_included_module_name>,
C<is_integer>,
C<is_method_call>,
C<is_package_declaration>,
C<is_perl_builtin>,
C<is_perl_global>,
C<is_perl_builtin_with_list_context>
C<is_perl_builtin_with_multiple_arguments>
C<is_perl_builtin_with_no_arguments>
C<is_perl_builtin_with_one_argument>
C<is_perl_builtin_with_optional_argument>
C<is_perl_builtin_with_zero_and_or_one_arguments>
C<is_script>,
C<is_subroutine_name>,
C<is_unchecked_call>
C<is_valid_numeric_verbosity>
See also L<Perl::Critic::Utils::PPI>.
=item C<:data_conversion>
Generic manipulation, not having anything specific to do with Perl::Critic.
Includes:
C<hashify>,
C<words_from_string>,
C<interpolate>
=item C<:ppi>
Things for dealing with L<PPI>, other than classification.
Includes:
C<first_arg>,
C<parse_arg_list>
See also L<Perl::Critic::Utils::PPI>.
=item C<:internal_lookup>
Translations between internal representations.
Includes:
C<severity_to_number>,
C<verbosity_to_format>
=item C<:language>
Information about Perl not programmatically available elsewhere.
Includes:
C<precedence_of>
=item C<:deprecated>
Not surprisingly, things that are deprecated.  It is preferred to use this tag
to get to these functions, rather than the function names themselves, so as to
mark any module using them as needing cleanup.
Includes:
C<find_keywords>
=back
=head1 SEE ALSO
L<Perl::Critic::Utils::Constants>,
L<Perl::Critic::Utils::McCabe>,
L<Perl::Critic::Utils::PPI>,
=head1 AUTHOR
Jeffrey Ryan Thalhammer <thaljef@cpan.org>
=head1 COPYRIGHT
Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer.  All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  The full text of this license
can be found in the LICENSE file included with this module.
=cut
# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :