git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm $
   3 #     $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
   4 #   $Author: clonezone $
   5 # $Revision: 2489 $
   6 ##############################################################################
   7
   8 package Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use Readonly;
  14
  15 use File::Spec;
  16
  17 use Perl::Critic::Utils qw{ :severities };
  18 use base 'Perl::Critic::Policy';
  19
  20 our $VERSION = '1.088';
  21
  22 #-----------------------------------------------------------------------------
  23
  24 Readonly::Scalar my $DESC => q{Package declaration must match filename};
  25 Readonly::Scalar my $EXPL => q{Correct the filename or package statement};
  26
  27 #-----------------------------------------------------------------------------
  28
  29 sub supported_parameters { return ()                }
  30 sub default_severity     { return $SEVERITY_HIGHEST }
  31 sub default_themes       { return qw(core bugs)     }
  32 sub applies_to           { return 'PPI::Document'   }
  33
  34 #-----------------------------------------------------------------------------
  35
  36 sub violates {
  37     my ($self, $elem, $doc) = @_;
  38
  39     my $filename = $doc->filename;
  40     return if !$filename;
  41
  42     # 'lib/Foo/Bar.pm' -> ('lib', 'Foo', 'Bar')
  43     my @path = File::Spec->splitpath($filename);
  44     $filename = $path[2];
  45     $filename =~ s/[.]\w+\z//mx;
  46     my @path_parts = grep {$_ ne q{}} File::Spec->splitdir($path[1]), $filename;
  47
  48     # 'Foo::Bar' -> ('Foo', 'Bar')
  49     my $pkg_node = $doc->find_first('PPI::Statement::Package');
  50     return if !$pkg_node;
  51     my $pkg = $pkg_node->namespace;
  52     return if $pkg eq 'main';
  53     my @pkg_parts = split m/(?:\'|::)/mx, $pkg;
  54
  55     # To succeed, at least the lastmost must match
  56     # Beyond that, the search terminates if a dirname is an impossible package name
  57     my $matched_any;
  58     while (@pkg_parts && @path_parts) {
  59         my $pkg_part = pop @pkg_parts;
  60         my $path_part = pop @path_parts;
  61         if ($pkg_part eq $path_part) {
  62             $matched_any = 1;
  63             next;
  64         }
  65
  66         # if it's a path that's not a possible package (like 'Foo-Bar-1.00'), that's OK
  67         last if ($path_part =~ m/\W/mx);
  68
  69         # Mismatched name
  70         return $self->violation( $DESC, $EXPL, $pkg_node );
  71     }
  72
  73     return if $matched_any;
  74     return $self->violation( $DESC, $EXPL, $pkg_node );
  75 }
  76
  77 1;
  78
  79 #-----------------------------------------------------------------------------
  80
  81 __END__
  82
  83 =pod
  84
  85 =head1 NAME
  86
  87 Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage - Package declaration must match filename.
  88
  89 =head1 AFFILIATION
  90
  91 This Policy is part of the core L<Perl::Critic> distribution.
  92
  93
  94 =head1 DESCRIPTION
  95
  96 The package declaration should always match the name of the file that
  97 contains it.  For example, C<package Foo::Bar;> should be in a file
  98 called C<Bar.pm>.
  99
 100
 101 =head1 CONFIGURATION
 102
 103 This Policy is not configurable except for the standard options.
 104
 105
 106 =head1 AUTHOR
 107
 108 Chris Dolan <cdolan@cpan.org>
 109
 110 =head1 COPYRIGHT
 111
 112 Copyright (C) 2006 Chris Dolan.  All rights reserved.
 113
 114 This program is free software; you can redistribute it and/or modify
 115 it under the same terms as Perl itself.
 116
 117 =cut
 118
 119 # Local Variables:
 120 #   mode: cperl
 121 #   cperl-indent-level: 4
 122 #   fill-column: 78
 123 #   indent-tabs-mode: nil
 124 #   c-indentation-style: bsd
 125 # End:
 126 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :