view release on metacpan or  search on metacpan

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

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 {
    # B::Keywords as of 1.08 forgot $\
    my @globals =
        map { substr $_, 1 }
            @B::Keywords::Arrays,
            @B::Keywords::Hashes,
            @B::Keywords::Scalars,
            '$\\'; ## no critic (RequireInterpolationOfMetachars)

    # 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 [\$@%*] }{}xms;  #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

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

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

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) = @_;  ## no critic(Variables::ProhibitReusedNames)
            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;
}

# Based upon autodie 2.10.
Readonly::Hash my %AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP => (
    # Map builtins to themselves.
    (
        map { $_ => { hashify( $_ ) } }
            qw<
                accept bind binmode chdir chmod close closedir connect
                dbmclose dbmopen exec fcntl fileno flock fork getsockopt ioctl
                link listen mkdir msgctl msgget msgrcv msgsnd open opendir
                pipe read readlink recv rename rmdir seek semctl semget semop
                send setsockopt shmctl shmget shmread shutdown socketpair
                symlink sysopen sysread sysseek system syswrite truncate umask
                unlink
            >
    ),

    # Generate these using tools/dump-autodie-tag-contents
    ':threads'      => { hashify( qw< fork                          > ) },
    ':system'       => { hashify( qw< exec system                   > ) },
    ':dbm'          => { hashify( qw< dbmclose dbmopen              > ) },
    ':semaphore'    => { hashify( qw< semctl semget semop           > ) },
    ':shm'          => { hashify( qw< shmctl shmget shmread         > ) },
    ':msg'          => { hashify( qw< msgctl msgget msgrcv msgsnd   > ) },
    ':file'     => {
        hashify(
            qw<
                binmode chmod close fcntl fileno flock ioctl open sysopen
                truncate
            >
        )
    },
    ':filesys'      => {
        hashify(
            qw<
                chdir closedir link mkdir opendir readlink rename rmdir
                symlink umask unlink
            >
        )
    },
    ':ipc'      => {
        hashify(
            qw<
                msgctl msgget msgrcv msgsnd pipe semctl semget semop shmctl
                shmget shmread
            >
        )
    },
    ':socket'       => {
        hashify(
            qw<
                accept bind connect getsockopt listen recv send setsockopt
                shutdown socketpair
            >
        )
    },
    ':io'       => {
        hashify(
            qw<
                accept bind binmode chdir chmod close closedir connect
                dbmclose dbmopen fcntl fileno flock getsockopt ioctl link
                listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe
                read readlink recv rename rmdir seek semctl semget semop send
                setsockopt shmctl shmget shmread shutdown socketpair symlink
                sysopen sysread sysseek syswrite truncate umask unlink
            >
        )
    },
    ':default'      => {
        hashify(
            qw<
                accept bind binmode chdir chmod close closedir connect
                dbmclose dbmopen fcntl fileno flock fork getsockopt ioctl link
                listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe
                read readlink recv rename rmdir seek semctl semget semop send
                setsockopt shmctl shmget shmread shutdown socketpair symlink
                sysopen sysread sysseek syswrite truncate umask unlink
            >
        )
    },
    ':all'      => {
        hashify(
            qw<
                accept bind binmode chdir chmod close closedir connect
                dbmclose dbmopen exec fcntl fileno flock fork getsockopt ioctl
                link listen mkdir msgctl msgget msgrcv msgsnd open opendir
                pipe read readlink recv rename rmdir seek semctl semget semop
                send setsockopt shmctl shmget shmread shutdown socketpair
                symlink sysopen sysread sysseek system syswrite truncate umask
                unlink
            >
        )
    },
);

sub _is_fatal {
    my ($elem) = @_;

    my $top = $elem->top();
    return if not $top->isa('PPI::Document');

    my $includes = $top->find('PPI::Statement::Include');
    return if not $includes;

    for my $include (@{$includes}) {
        next if 'use' ne $include->type();

        if ('Fatal' eq $include->module()) {
            my @args = parse_arg_list($include->schild(1));
            foreach my $arg (@args) {
                return $TRUE 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
            foreach my $arg (@args) {
                return $TRUE if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string();
            }
        }
        elsif ('autodie' eq $include->pragma()) {
            return _is_covered_by_autodie($elem, $include);
        }
    }

    return;
}

sub _is_covered_by_autodie {
    my ($elem, $include) = @_;

    my @args = parse_arg_list($include->schild(1));

    if (@args) {
        foreach my $arg (@args) {
            my $builtins =
                $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{
                    $arg->[0]->string
                };

            return $TRUE if $builtins and $builtins->{$elem->content()};
        }
    }
    else {