1package Perl::Lint::Policy::ValuesAndExpressions::RequireConstantVersion;
2use strict;
3use warnings;
4use Perl::Lint::Constants::Type;
5use parent "Perl::Lint::Policy";
6
7use constant {
8    DESC => '$VERSION value must be a constant',
9    EXPL => 'Computed $VERSION may tie the code to a single repository, or cause spooky action from a distance',
10};
11
12sub evaluate {
13    my ($class, $file, $tokens, $src, $args) = @_;
14
15    my $is_used_version = 0;
16    if (my $this_packages_arg = $args->{require_constant_version}) {
17        $is_used_version = $this_packages_arg->{allow_version_without_use_on_same_line};
18    }
19
20    my @violations;
21
22    my $is_version_assigner = 0;
23
24    TOP: for (my $i = 0, my $token_type, my $token_data; my $token = $tokens->[$i]; $i++) {
25        $token_type = $token->{type};
26        $token_data = $token->{data};
27
28        # `use version;` declared?
29        if ($token_type == USED_NAME && $token_data eq 'version') {
30            $is_used_version = 1;
31            next;
32        }
33
34        # in assigning context?
35        if ($token_type == ASSIGN) {
36            $is_version_assigner = 1;
37            next;
38        }
39
40        # reset context information
41        if ($token_type == SEMI_COLON) {
42            $is_version_assigner = 0;
43            next;
44        }
45
46        if ($token_type == BUILTIN_FUNC) {
47            $token = $tokens->[++$i] or last;
48            if ($token->{type} == LEFT_PAREN) {
49                # skip tokens which are surrounded by parenthesis
50                my $lpnum = 1;
51                for ($i++; $token = $tokens->[$i]; $i++) {
52                    $token_type = $token->{type};
53
54                    if ($token_type == LEFT_PAREN) {
55                        $lpnum++;
56                    }
57                    elsif ($token_type == RIGHT_PAREN) {
58                        last if --$lpnum <= 0;
59                    }
60                }
61            }
62            # else: skip a token (means NOP)
63        }
64
65        if ($token_type != GLOBAL_VAR && $token_type != VAR) {
66            next;
67        }
68
69        if ($token_data ne '$VERSION') {
70            next;
71        }
72
73        if ($is_version_assigner) {
74            # skip this!
75            $is_version_assigner = 0;
76            next;
77        }
78
79        my $is_invalid = 0;
80        my $is_var_assigned = 0;
81
82        # check assigning context or not
83        for ($i++; $token = $tokens->[$i]; $i++) {
84            $token_type = $token->{type};
85
86            if ($token_type == ASSIGN || $token_type == OR_EQUAL) {
87                last;
88            }
89            elsif ($token_type == REG_OK) {
90                $is_invalid = 1;
91                last;
92            }
93            elsif ($token_type == SEMI_COLON) {
94                next TOP;
95            }
96        }
97
98        if ($is_invalid) {
99            goto JUDGEMENT;
100        }
101
102        for ($i++; $token = $tokens->[$i]; $i++) {
103            $token_type = $token->{type};
104            $token_data = $token->{data};
105
106            if ($token_type == SEMI_COLON) {
107                last;
108            }
109            elsif ($token_type == STRING) {
110                if ($is_invalid = $class->_is_interpolation($token_data)) {
111                    last;
112                }
113            }
114            elsif ($token_type == REG_DOUBLE_QUOTE) {
115                $i += 2; # skip delimiter
116                $token = $tokens->[$i] or last;
117                if ($is_invalid = $class->_is_interpolation($token->{data})) {
118                    last;
119                }
120            }
121            elsif (
122                $token_type == BUILTIN_FUNC ||
123                $token_type == DO           || # do {...}
124                $token_type == STRING_MUL   || # "a" x 42
125                $token_type == NAMESPACE    || # call other package
126                $token_type == REG_OK       || # =~
127                $token_type == LEFT_BRACKET    # access element of array
128            ) {
129                $is_invalid = 1;
130                last;
131            }
132            elsif ($token_type == ASSIGN) {
133                $is_var_assigned = 0;
134            }
135            elsif ($token_type == VAR || $token_type == GLOBAL_VAR) {
136                $is_var_assigned = 1;
137            }
138            elsif ($token_type == KEY) {
139                if ($token_data eq 'qv') { # for `qv(...)` notation
140                    if (!$is_used_version) {
141                        $is_invalid = 1;
142                        last;
143                    }
144                }
145                elsif ($token_data eq 'version') { # for `version->new(...)` notation
146                    if (!$is_used_version) {
147                        $is_invalid = 1;
148                        last;
149                    }
150
151                    $token = $tokens->[++$i] or last;
152                    if ($token->{type} != POINTER) {
153                        next;
154                    }
155
156                    $token = $tokens->[++$i] or last;
157                    if ($token->{type} != METHOD && $token->{data} ne 'new') {
158                        next;
159                    }
160                }
161                else { # for others
162                    $is_invalid = 1;
163                    last;
164                }
165            }
166        }
167
168        JUDGEMENT:
169        if ($is_invalid || $is_var_assigned) {
170            push @violations, {
171                filename => $file,
172                line     => $token->{line},
173                description => DESC,
174                explanation => EXPL,
175                policy => __PACKAGE__,
176            };
177        }
178    }
179
180    return \@violations;
181}
182
183sub _is_interpolation {
184    my ($class, $str) = @_;
185
186    while ($str =~ /(\\*)(\$\S+)/gc) {
187        if (length($1) % 2 == 0) {
188            # sigil is not escaped
189            # interpolated!
190            return 1;
191        }
192        else {
193            # sigil is escaped
194            next;
195        }
196    }
197
198    return;
199}
200
2011;
202
203