1package Perl::Lint::Policy::Subroutines::ProtectPrivateSubs;
2use strict;
3use warnings;
4use Perl::Lint::Constants::Type;
5use parent "Perl::Lint::Policy";
6
7use constant {
8    DESC => 'Private subroutine/method used',
9    EXPL => 'Use published APIs',
10};
11
12sub evaluate {
13    my ($class, $file, $tokens, $src, $args) = @_;
14
15    my @allows = ();
16    for my $allow (split(/ /, $args->{protect_private_subs}->{allow} || '')) {
17        my @name_spaces = split /::/, $allow;
18        my $method_name = pop @name_spaces;
19        push @allows, +{
20            package_name => join('::', @name_spaces),
21            method_name  => $method_name,
22        };
23    }
24    my $private_name_regex = $args->{protect_private_subs}->{private_name_regex} || '';
25
26    my @violations;
27    my $module_name = '';
28    TOP: for (my $i = 0; my $token = $tokens->[$i]; $i++) {
29        my $token_type = $token->{type};
30        my $token_data = $token->{data};
31
32        if ($token_type == POINTER || $token_type == NAMESPACE_RESOLVER) {
33            my $delimiter = $token_data;
34
35            $token = $tokens->[++$i];
36            $token_data = $token->{data};
37            my $next_token = $tokens->[$i+1];
38            my $next_token_type = $next_token->{type};
39            if (
40                substr($token_data, 0, 1) eq '_' &&
41                $next_token_type != POINTER &&
42                $next_token_type != NAMESPACE_RESOLVER
43            ) {
44                for my $allow (@allows) {
45                    if (
46                        $allow->{package_name} eq $module_name &&
47                        $allow->{method_name} eq $token_data
48                    ) {
49                        next TOP;
50                    }
51                }
52
53                if ($private_name_regex && $token_data =~ /$private_name_regex/) {
54                    next;
55                }
56
57                push @violations, {
58                    filename => $file,
59                    line     => $token->{line},
60                    description => DESC,
61                    explanation => EXPL,
62                    policy => __PACKAGE__,
63                };
64                $module_name = '';
65            }
66            else {
67                $module_name .= $delimiter . $token_data;
68            }
69        }
70        elsif (
71            $token_type == USE_DECL ||
72            $token_type == REQUIRE_DECL ||
73            $token_type == PACKAGE
74        ) {
75            for ($i++; $token = $tokens->[$i]; $i++) {
76                $token_type = $token->{type};
77                if ($token_type == SEMI_COLON) {
78                    last;
79                }
80            }
81        }
82        elsif (
83            ($token_type == SPECIFIC_KEYWORD && $token_data eq '__PACKAGE__') ||
84            ($token_type == BUILTIN_FUNC && $token_data eq 'shift') ||
85            ($token_type == NAMESPACE && $token_data eq 'POSIX')
86        ) {
87            $i++; # skip target func
88        }
89        elsif ($token_type == NAMESPACE) {
90            $module_name .= $token_data;
91        }
92        elsif (
93            (
94                $token_type == VAR ||
95                $token_type == GLOBAL_VAR ||
96                $token_type == LOCAL_VAR
97            ) && ($token_data eq '$pkg' || $token_data eq '$self')
98        ) {
99            $i++;
100            my $next_token = $tokens->[$i+1];
101            if ($next_token->{type} == NAMESPACE && $next_token->{data} eq 'SUPER') {
102                $i += 2;
103            }
104        }
105        elsif ($token_type == SEMI_COLON) {
106            $module_name = '';
107        }
108    }
109
110    return \@violations;
111}
112
1131;
114
115