From 06a8e26d996ea75869c02adb07009a776143867e Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Lars=20D=C9=AA=E1=B4=87=E1=B4=84=E1=B4=8B=E1=B4=8F=E1=B4=A1?= <daxim@cpan.org>
Date: Sat, 11 Apr 2009 21:07:49 +0200
Subject: [PATCH] make configurable
---
.../Policy/Modules/RequireExplicitInclusion.pm | 62 ++++++++++++++++++--
1 files changed, 56 insertions(+), 6 deletions(-)
diff --git a/Perl-Critic-StricterSubs/lib/Perl/Critic/Policy/Modules/RequireExplicitInclusion.pm b/Perl-Critic-StricterSubs/lib/Perl/Critic/Policy/Modules/RequireExplicitInclusion.pm
index 2e189ef..6c12249 100644
--- a/Perl-Critic-StricterSubs/lib/Perl/Critic/Policy/Modules/RequireExplicitInclusion.pm
+++ b/Perl-Critic-StricterSubs/lib/Perl/Critic/Policy/Modules/RequireExplicitInclusion.pm
@@ -20,6 +20,7 @@ use Perl::Critic::Utils qw(
&is_perl_builtin
&is_qualified_name
&policy_short_name
+ &words_from_string
);
use Perl::Critic::StricterSubs::Utils qw(
@@ -36,13 +37,35 @@ my $expl =
#-----------------------------------------------------------------------------
-sub supported_parameters { return }
+sub supported_parameters { return qw(exempt_packages) }
sub default_severity { return $SEVERITY_HIGH }
sub default_themes { return qw( strictersubs bugs ) }
sub applies_to { return 'PPI::Document' }
#-----------------------------------------------------------------------------
+sub new {
+ my ( $class, %args ) = @_;
+ my $self = bless {}, $class;
+ $self->{_exempt_packages} = {'__PACKAGE__' => 1}; # always exempt
+
+ if (defined $args{exempt_packages} ) {
+ for my $package ( words_from_string( $args{exempt_packages} ) ) {
+ if ($package =~ m|\A / (.*) / \z|msx) {
+ # regexp, like /^XML::LibXML::.*/
+ push @{ $self->{_exempt_packages_re} }, qr/$1/;
+ } else {
+ # literal names, like Gtk2::TreeStore
+ $self->{_exempt_packages}->{$package} = 1;
+ }
+ }
+ }
+
+ return $self;
+}
+
+#-----------------------------------------------------------------------------
+
sub violates {
my ($self, undef, $doc) = @_;
@@ -51,7 +74,7 @@ sub violates {
if ( @declared_packages > 1 ) {
my $fname = $doc->filename() || 'unknown';
my $pname = policy_short_name(__PACKAGE__);
- warn qq{$pname: Cannot cope with mutiple packages in file "$fname"\n};
+ warn qq{$pname: Cannot cope with multiple packages in file "$fname"\n};
return;
}
@@ -179,6 +202,18 @@ sub _extract_package_from_symbol {
#-----------------------------------------------------------------------------
+sub _is_exempt_package {
+ my ($self, $package_name) = @_;
+ $package_name = "$package_name"; # stringify the PPI::Token
+ return 1 if exists $self->{_exempt_packages}->{$package_name};
+ for my $package_name_regexp (@{ $self->{_exempt_packages_re} }) {
+ return 1 if $package_name =~ $package_name_regexp;
+ }
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
sub _find_violations {
my ($self, $doc, $included_packages, $finder, $package_extractor) = @_;
@@ -189,7 +224,9 @@ sub _find_violations {
next if exists $included_packages->{ $package };
my $desc = qq{Use of "$call" without including "$package"};
- push @violations, $self->violation( $desc, $expl, $call );
+ unless ($self->_is_exempt_package($package)) {
+ push @violations, $self->violation( $desc, $expl, $call );
+ };
}
return @violations;
@@ -289,6 +326,8 @@ because C<Foo::bar()> doesn't exist.
=head2 Enforcement
+The special literal C<__PACKAGE__> is always exempt.
+
Assuming that there are no C<use> or C<require> statements within the
current scope:
@@ -392,19 +431,30 @@ C<process_widgets()> subroutine actually exists in the C<Foo> package.
=head1 CONFIGURATION
-None.
+A list of exempt package names for this policy can be defined by specifying
+C<exempt_packages> as a string of space-delimited names. If framed in slashes,
+it is not taken literal, but as a regular expression. For example, putting this
+in your F<.perlcriticrc> file would allow you to make reference to something in
+the C<Gtk2::TreeStore> package and all packages starting with C<XML::LibXML::>,
+as they are but part of files that contain multiple packages with the main names
+C<Gtk2> and C<XML::LibXML>.
+
+ [Modules::RequireExplicitInclusion]
+ exempt_packages = Gtk2::TreeStore /^XML::LibXML::.*/
+
+By default the special literal C<__PACKAGE__> alone is exempt.
=head1 DIAGNOSTICS
=over
-=item C<Modules::RequireExplicitInclusion: Cannot cope with mutiple packages in file>
+=item C<Modules::RequireExplicitInclusion: Cannot cope with multiple packages in file>
This warning happens when the file under analysis contains multiple packages,
which is not currently supported. This Policy will simply ignore any file
with multiple packages.
-L<Perl::Critic> advises putting multiple packages in one file, and has
+L<Perl::Critic> advises against putting multiple packages in one file, and has
additional Policies to help enforce that.
=back
--
1.6.0.2
