1package Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName;
2
3use 5.006001;
4
5use strict;
6use warnings;
7
8use Readonly;
9use English qw{ -no_match_vars };
10use Perl::Critic::Utils qw{ :severities :classification };
11use base 'Perl::Critic::Policy';
12
13our $VERSION = '1.140';
14
15#-----------------------------------------------------------------------------
16
17Readonly::Scalar my $PKG_RX => qr{ [[:alpha:]](?:[\w:\']*\w)? }xms;
18Readonly::Scalar my $DESC =>
19    q{Pod NAME on line %d does not match the package declaration};
20Readonly::Scalar my $EXPL => q{};
21
22#-----------------------------------------------------------------------------
23
24sub supported_parameters { return ()                      }
25sub default_severity     { return $SEVERITY_LOWEST        }
26sub default_themes       { return qw( core cosmetic )     }
27sub applies_to           { return 'PPI::Document'         }
28
29#-----------------------------------------------------------------------------
30
31sub prepare_to_scan_document {
32    my ( $self, $document ) = @_;
33
34    # idea: force NAME to match the file name in programs?
35    return $document->is_module(); # mismatch is normal in program entry points
36}
37
38sub violates {
39    my ( $self, $elem, $doc ) = @_;
40
41    # No POD means no violation
42    my $pods_ref = $doc->find('PPI::Token::Pod');
43    return if !$pods_ref;
44
45    for my $pod (@{$pods_ref}) {
46        my $content = $pod->content;
47
48        next if $content !~ m{^=head1 [ \t]+ NAME [ \t]*$ \s*}cgxms;
49
50        my $line_number = $pod->line_number() + (
51            substr( $content, 0, $LAST_MATCH_START[0] + 1 ) =~ tr/\n/\n/ );
52
53        my ($pod_pkg) = $content =~ m{\G (\S+) }cgxms;
54
55        if (!$pod_pkg) {
56            return $self->violation( sprintf( $DESC, $line_number ),
57                q{Empty name declaration}, $pod );
58        }
59
60        # idea: worry about POD escapes?
61        $pod_pkg =~ s{\A [BCIL]<(.*)>\z}{$1}gxms; # unwrap
62        $pod_pkg =~ s{\'}{::}gxms;                # perl4 -> perl5
63
64        foreach my $stmt ( @{ $doc->find('PPI::Statement::Package') || [] } ) {
65            my $pkg = $stmt->namespace();
66            $pkg =~ s{\'}{::}gxms;
67            return if $pkg eq $pod_pkg;
68        }
69
70        return $self->violation( sprintf( $DESC, $line_number ),
71            $EXPL, $pod );
72    }
73
74    return;  # no NAME section found
75}
76
771;
78
79__END__
80
81#-----------------------------------------------------------------------------
82
83=pod
84
85=head1 NAME
86
87Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName - The C<=head1 NAME> section should match the package.
88
89
90=head1 AFFILIATION
91
92This Policy is part of the core L<Perl::Critic|Perl::Critic> distribution.
93
94
95=head1 DESCRIPTION
96
97
98=head1 CONFIGURATION
99
100This Policy is not configurable except for the standard options.
101
102
103=head1 AUTHOR
104
105Chris Dolan <cdolan@cpan.org>
106
107
108=head1 COPYRIGHT
109
110Copyright (c) 2008-2011 Chris Dolan
111
112This program is free software; you can redistribute it and/or modify
113it under the same terms as Perl itself.  The full text of this license
114can be found in the LICENSE file included with this module
115
116=cut
117
118# Local Variables:
119#   mode: cperl
120#   cperl-indent-level: 4
121#   fill-column: 78
122#   indent-tabs-mode: nil
123#   c-indentation-style: bsd
124# End:
125# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
126