—

              
##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm $
#     $Date: 2010-12-14 20:31:40 -0600 (Tue, 14 Dec 2010) $
#   $Author: clonezone $
# $Revision: 4011 $
##############################################################################
package Perl::Critic::Policy::Subroutines::ProtectPrivateSubs;
use 5.006001;
use strict;
use warnings;
use English qw< $EVAL_ERROR -no_match_vars >;
use Readonly;
use Perl::Critic::Utils qw<
    :severities $EMPTY is_function_call is_method_call
>;
use base 'Perl::Critic::Policy';
our $VERSION = '1.112_001';
#-----------------------------------------------------------------------------
Readonly::Scalar my $DESC => q<Private subroutine/method used>;
Readonly::Scalar my $EXPL => q<Use published APIs>;
#-----------------------------------------------------------------------------
sub supported_parameters {
    return (
        {
            name            => 'private_name_regex',
            description     => 'Pattern that determines what a private subroutine is.',
            default_string  => '\b_\w+\b',  ## no critic (RequireInterpolationOfMetachars)
            behavior        => 'string',
            parser          => \& _parse_private_name_regex,
        },
        {
            name            => 'allow',
            description     =>
                q<Subroutines matching the private name regex to allow under this policy.>,
            default_string  => $EMPTY,
            behavior        => 'string list',
            list_always_present_values => [ qw<
                POSIX::_PC_CHOWN_RESTRICTED
                POSIX::_PC_LINK_MAX
                POSIX::_PC_MAX_CANON
                POSIX::_PC_MAX_INPUT
                POSIX::_PC_NAME_MAX
                POSIX::_PC_NO_TRUNC
                POSIX::_PC_PATH_MAX
                POSIX::_PC_PIPE_BUF
                POSIX::_PC_VDISABLE
                POSIX::_POSIX_ARG_MAX
                POSIX::_POSIX_CHILD_MAX
                POSIX::_POSIX_CHOWN_RESTRICTED
                POSIX::_POSIX_JOB_CONTROL
                POSIX::_POSIX_LINK_MAX
                POSIX::_POSIX_MAX_CANON
                POSIX::_POSIX_MAX_INPUT
                POSIX::_POSIX_NAME_MAX
                POSIX::_POSIX_NGROUPS_MAX
                POSIX::_POSIX_NO_TRUNC
                POSIX::_POSIX_OPEN_MAX
                POSIX::_POSIX_PATH_MAX
                POSIX::_POSIX_PIPE_BUF
                POSIX::_POSIX_SAVED_IDS
                POSIX::_POSIX_SSIZE_MAX
                POSIX::_POSIX_STREAM_MAX
                POSIX::_POSIX_TZNAME_MAX
                POSIX::_POSIX_VDISABLE
                POSIX::_POSIX_VERSION
                POSIX::_SC_ARG_MAX
                POSIX::_SC_CHILD_MAX
                POSIX::_SC_CLK_TCK
                POSIX::_SC_JOB_CONTROL
                POSIX::_SC_NGROUPS_MAX
                POSIX::_SC_OPEN_MAX
                POSIX::_SC_PAGESIZE
                POSIX::_SC_SAVED_IDS
                POSIX::_SC_STREAM_MAX
                POSIX::_SC_TZNAME_MAX
                POSIX::_SC_VERSION
                POSIX::_exit
            > ],
        },
    );
}
sub default_severity     { return $SEVERITY_MEDIUM       }
sub default_themes       { return qw( core maintenance ) }
sub applies_to           { return 'PPI::Token::Word'     }
#-----------------------------------------------------------------------------
sub _parse_private_name_regex {
    my ($self, $parameter, $config_string) = @_;
    defined $config_string
        or $config_string = $parameter->get_default_string();
    my $regex;
    eval { $regex = qr/$config_string/; 1 } ## no critic (RegularExpressions)
        or $self->throw_parameter_value_exception(
            'private_name_regex',
            $config_string,
            undef,
            "is not a valid regular expression: $EVAL_ERROR",
        );
    $self->__set_parameter_value($parameter, $regex);
    return;
}
#-----------------------------------------------------------------------------
sub violates {
    my ( $self, $elem, undef ) = @_;
    if ( my $prior = $elem->sprevious_sibling() ) {
        my $prior_name = $prior->content();
        return if $prior_name eq 'package';
        return if $prior_name eq 'require';
        return if $prior_name eq 'use';
    }
    if (
            $self->_is_other_pkg_private_function($elem)
        or  $self->_is_other_pkg_private_method($elem)
    ) {
        return $self->violation( $DESC, $EXPL, $elem );
    }
    return;  # ok!
}
sub _is_other_pkg_private_function {
    my ( $self, $elem ) = @_;
    return if ! is_function_call($elem) && ! is_method_call($elem);
    my $private_name_regex = $self->{_private_name_regex};
    my $content = $elem->content();
    return
            $content =~ m< \w+::$private_name_regex \z >xms
        &&  $content !~ m< \A SUPER::$private_name_regex \z >xms
        &&  ! $self->{_allow}{$content};
}
sub _is_other_pkg_private_method {
    my ( $self, $elem ) = @_;
    my $private_name_regex = $self->{_private_name_regex};
    my $content = $elem->content();
    # look for structures like "Some::Package->_foo()"
    return if $content !~ m< \A $private_name_regex \z >xms;
    my $operator = $elem->sprevious_sibling() or return;
    return if $operator->content() ne q[->];
    my $package = $operator->sprevious_sibling() or return;
    return if not $package->isa('PPI::Token::Word');
    # sometimes the previous sib is a keyword, as in:
    # shift->_private_method();  This is typically used as
    # shorthand for "my $self=shift; $self->_private_method()"
    return if $package eq 'shift' or $package eq '__PACKAGE__';
    # Maybe the user wanted to exempt this explicitly.
    return if $self->{_allow}{"${package}::$content"};
    return 1;
}
1;
__END__
#-----------------------------------------------------------------------------
HideShow 83 lines of Pod
=pod
=head1 NAME
Perl::Critic::Policy::Subroutines::ProtectPrivateSubs - Prevent access to private subs in other packages.
=head1 AFFILIATION
This Policy is part of the core L<Perl::Critic|Perl::Critic>
distribution.
=head1 DESCRIPTION
By convention Perl authors (like authors in many other languages)
indicate private methods and variables by inserting a leading
underscore before the identifier.  This policy catches attempts to
access private variables from outside the package itself.
The subroutines in the L<POSIX|POSIX> package which begin with an underscore
(e.g. C<POSIX::_POSIX_ARG_MAX>) are not flagged as errors by this
policy.
=head1 CONFIGURATION
You can define what a private subroutine name looks like by specifying
a regular expression for the C<private_name_regex> option in your
F<.perlcriticrc>:
    [Subroutines::ProtectPrivateSubs]
    private_name_regex = _(?!_)\w+
The above example is a way of saying that subroutines that start with
a double underscore are not considered to be private.  (Perl::Critic,
in its implementation, uses leading double underscores to indicate a
distribution-private subroutine-- one that is allowed to be invoked by
other Perl::Critic modules, but not by anything outside of
Perl::Critic.)
You can configure additional subroutines to accept by specifying them
in a space-delimited list to the C<allow> option:
    [Subroutines::ProtectPrivateSubs]
    allow = FOO::_bar FOO::_baz
These are added to the default list of exemptions from this policy.
Allowing a subroutine also allows the corresponding method call. So
C<< FOO::_bar >> in the above example allows both C<< FOO::_bar() >>
and C<< FOO->_bar() >>.
=head1 HISTORY
This policy is inspired by a similar test in L<B::Lint|B::Lint>.
=head1 BUGS
Doesn't forbid C<< $pkg->_foo() >> because it can't tell the
difference between that and C<< $self->_foo() >>.
=head1 SEE ALSO
L<Perl::Critic::Policy::Variables::ProtectPrivateVars|Perl::Critic::Policy::Variables::ProtectPrivateVars>
=head1 AUTHOR
Chris Dolan <cdolan@cpan.org>
=head1 COPYRIGHT
Copyright (c) 2006-2010 Chris Dolan.
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 :