| Subject: | add exempt_subs to ProhibitCallsToUnexportedSubs.pm |
This patch adds the exempt_subs configuration option as promised in the documentation.
| Subject: | ProhibitCallsToUnexportedSubs.pm.003.diff |
Index: ProhibitCallsToUnexportedSubs.pm
===================================================================
--- ProhibitCallsToUnexportedSubs.pm (revision 12839)
+++ ProhibitCallsToUnexportedSubs.pm (working copy)
@@ -22,6 +22,7 @@
&is_perl_builtin
&is_qualified_name
&policy_short_name
+ &words_from_string
);
use Perl::Critic::StricterSubs::Utils qw{
@@ -40,7 +41,7 @@
#-----------------------------------------------------------------------------
sub supported_parameters {
- return qw( at_inc_prefix use_standard_at_inc at_inc_suffix );
+ return qw( at_inc_prefix use_standard_at_inc at_inc_suffix exempt_subs);
}
sub default_severity { return $SEVERITY_HIGH }
@@ -79,6 +80,12 @@
die policy_short_name(__PACKAGE__), " has no directories in its module search path.\n"
if not @inc;
+ if (defined $config{exempt_subs} ) {
+ for my $qualified_sub ( words_from_string( $config{exempt_subs} ) ){
+ my ($package, $sub_name) = _parse_sub_name( $qualified_sub );
+ $self->{_exempt_subs}->{$package}->{$sub_name} = 1;
+ }
+ }
$self->{_inc} = File::PathList->new( paths => \@inc, cache => 1 );
$self->{_exports_by_package} = {};
@@ -99,18 +106,49 @@
#-----------------------------------------------------------------------------
+sub _parse_sub_name {
+
+ my $full_name = shift;
+
+ if ( $full_name =~ m/\A ( .+ ) :: ([^:]+) \z/xms ) {
+
+ my ($package_name, $sub_name) = ($1, $2);
+ return ($package_name, $sub_name);
+ }
+ else {
+
+ die qq{Sub name "$full_name" must be fully qualifed.\n};
+ }
+}
+
+sub _is_exempt_subroutine {
+
+ my ($self, $sub_name, $included_packages) = @_;
+ for my $package ( @{$included_packages} ) {
+ return 1 if exists $self->{_exempt_subs}->{$package}->{$sub_name};
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
sub violates {
my ($self, undef, $doc) = @_;
my @violations = ();
my $expl = q{Violates encapsulation};
+# my @included_packages = get_package_names_from_include_statements( $doc );
+
for my $sub_call ( find_subroutine_calls($doc) ) {
next if not is_qualified_name( $sub_call );
my ($package, $sub_name) = $self->_parse_subroutine_call( $sub_call );
next if _is_builtin_package( $package );
+ next if $self->_is_exempt_subroutine( $sub_name, [$package,] );
+
my $exports = $self->_get_exports_for_package( $package );
if ( not exists $exports->{ $sub_name } ){