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