File Coverage

blib/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm
Criterion Covered Total %
statement 98 98 100.0
branch 47 68 69.1
condition 10 12 83.3
subroutine 18 18 100.0
pod 4 5 80.0
total 177 201 88.0


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros;
2              
3 40     40   27411 use 5.010001;
  40         165  
4 40     40   220 use strict;
  40         124  
  40         813  
5 40     40   197 use warnings;
  40         90  
  40         945  
6              
7 40     40   222 use Readonly;
  40         100  
  40         2027  
8              
9 40     40   325 use Perl::Critic::Utils qw{ :characters :severities hashify };
  40         123  
  40         2121  
10 40     40   12083 use parent 'Perl::Critic::Policy';
  40         116  
  40         238  
11              
12             our $VERSION = '1.148';
13              
14             #-----------------------------------------------------------------------------
15              
16             Readonly::Scalar my $LEADING_RX => qr<\A [+-]? (?: 0+ _* )+ [1-9]>xms;
17             Readonly::Scalar my $EXPL => [ 58 ];
18              
19             #-----------------------------------------------------------------------------
20              
21             sub supported_parameters {
22             return (
23             {
24 105     105 0 2088 name => 'strict',
25             description =>
26             q<Don't allow any leading zeros at all. Otherwise builtins that deal with Unix permissions, e.g. chmod, don't get flagged.>,
27             default_string => '0',
28             behavior => 'boolean',
29             },
30             );
31             }
32              
33 117     117 1 612 sub default_severity { return $SEVERITY_HIGHEST }
34 92     92 1 419 sub default_themes { return qw< core pbp bugs certrec > }
35 51     51 1 192 sub applies_to { return 'PPI::Token::Number::Octal' }
36              
37             #-----------------------------------------------------------------------------
38              
39             sub violates {
40 63     63 1 173 my ( $self, $elem, undef ) = @_;
41              
42 63 100       336 return if $elem !~ $LEADING_RX;
43 61 100       697 return $self->_create_violation($elem) if $self->{_strict};
44 44 100       173 return if $self->_is_first_argument_of_chmod_or_umask($elem);
45 38 100       145 return if $self->_is_second_argument_of_mkdir($elem);
46 36 100       257 return if $self->_is_second_argument_of_mkfifo($elem);
47 32 100       230 return if $self->_is_third_argument_of_dbmopen($elem);
48 30 100       220 return if $self->_is_fourth_argument_of_sysopen($elem);
49 26         189 return $self->_create_violation($elem);
50             }
51              
52             sub _create_violation {
53 43     43   114 my ($self, $elem) = @_;
54              
55 43         144 return $self->violation(
56             qq<Integer with leading zeros: "$elem">,
57             $EXPL,
58             $elem
59             );
60             }
61              
62             sub _is_first_argument_of_chmod_or_umask {
63 44     44   121 my ($self, $elem) = @_;
64              
65 44         138 my $previous_token = _previous_token_that_isnt_a_parenthesis($elem);
66 44 50       157 return if not $previous_token;
67              
68 44         126 my $content = $previous_token->content();
69 44   100     352 return $content eq 'chmod' || $content eq 'umask';
70             }
71              
72             sub _is_second_argument_of_mkdir {
73 38     38   134 my ($self, $elem) = @_;
74              
75             # Preceding comma.
76 38         95 my $previous_token = _previous_token_that_isnt_a_parenthesis($elem);
77 38 50       160 return if not $previous_token;
78 38 100       111 return if $previous_token->content() ne $COMMA; # Don't know what it is.
79              
80             # Directory name.
81 12         67 $previous_token =
82             _previous_token_that_isnt_a_parenthesis($previous_token);
83 12 50       53 return if not $previous_token;
84              
85 12         34 $previous_token =
86             _previous_token_that_isnt_a_parenthesis($previous_token);
87 12 50       50 return if not $previous_token;
88              
89 12         36 return $previous_token->content() eq 'mkdir';
90             }
91              
92             sub _is_second_argument_of_mkfifo {
93 36     36   98 my ($self, $elem) = @_;
94              
95             # Preceding comma.
96 36         99 my $previous_token = _previous_token_that_isnt_a_parenthesis($elem);
97 36 50       168 return if not $previous_token;
98 36 100       102 return if $previous_token->content() ne $COMMA; # Don't know what it is.
99              
100             # FIFO name.
101 10         52 $previous_token =
102             _previous_token_that_isnt_a_parenthesis($previous_token);
103 10 50       37 return if not $previous_token;
104              
105 10         28 $previous_token =
106             _previous_token_that_isnt_a_parenthesis($previous_token);
107 10 50       37 return if not $previous_token;
108              
109 10         24 state $is_mkfifo = { hashify( 'mkfifo', 'POSIX::mkfifo' ) };
110 10         27 return $is_mkfifo->{$previous_token->content()};
111             }
112              
113             sub _is_third_argument_of_dbmopen {
114 32     32   82 my ($self, $elem) = @_;
115              
116             # Preceding comma.
117 32         70 my $previous_token = _previous_token_that_isnt_a_parenthesis($elem);
118 32 50       140 return if not $previous_token;
119 32 100       96 return if $previous_token->content() ne $COMMA; # Don't know what it is.
120              
121             # File path.
122 6         34 $previous_token =
123             _previous_token_that_isnt_a_parenthesis($previous_token);
124 6 50       26 return if not $previous_token;
125              
126             # Another comma.
127 6         23 $previous_token =
128             _previous_token_that_isnt_a_parenthesis($previous_token);
129 6 50       27 return if not $previous_token;
130 6 100       19 return if $previous_token->content() ne $COMMA; # Don't know what it is.
131              
132             # Variable name.
133 4         29 $previous_token =
134             _previous_token_that_isnt_a_parenthesis($previous_token);
135 4 50       20 return if not $previous_token;
136              
137 4         13 $previous_token =
138             _previous_token_that_isnt_a_parenthesis($previous_token);
139 4 50       16 return if not $previous_token;
140              
141 4         13 return $previous_token->content() eq 'dbmopen';
142             }
143              
144             sub _is_fourth_argument_of_sysopen {
145 30     30   77 my ($self, $elem) = @_;
146              
147             # Preceding comma.
148 30         64 my $previous_token = _previous_token_that_isnt_a_parenthesis($elem);
149 30 50       115 return if not $previous_token;
150 30 100       82 return if $previous_token->content() ne $COMMA; # Don't know what it is.
151              
152             # Mode.
153 4         22 $previous_token =
154             _previous_token_that_isnt_a_parenthesis($previous_token);
155 4   66     25 while ($previous_token and $previous_token->content() ne $COMMA) {
156 12         67 $previous_token =
157             _previous_token_that_isnt_a_parenthesis($previous_token);
158             }
159 4 50       29 return if not $previous_token;
160 4 50       12 return if $previous_token->content() ne $COMMA; # Don't know what it is.
161              
162             # File name.
163 4         22 $previous_token =
164             _previous_token_that_isnt_a_parenthesis($previous_token);
165 4 50       16 return if not $previous_token;
166              
167             # Yet another comma.
168 4         11 $previous_token =
169             _previous_token_that_isnt_a_parenthesis($previous_token);
170 4 50       16 return if not $previous_token;
171 4 50       15 return if $previous_token->content() ne $COMMA; # Don't know what it is.
172              
173             # File handle.
174 4         24 $previous_token =
175             _previous_token_that_isnt_a_parenthesis($previous_token);
176 4 50       17 return if not $previous_token;
177              
178 4         13 $previous_token =
179             _previous_token_that_isnt_a_parenthesis($previous_token);
180 4 50       15 return if not $previous_token;
181              
182             # GitHub #789
183 4 100       14 if ( $previous_token->content() eq 'my' ) {
184 1         9 $previous_token = _previous_token_that_isnt_a_parenthesis(
185             $previous_token );
186 1 50       6 return if not $previous_token;
187             }
188              
189 4         20 return $previous_token->content() eq 'sysopen';
190             }
191              
192             sub _previous_token_that_isnt_a_parenthesis {
193 277     277   497 my ($elem) = @_;
194              
195 277         550 state $is_paren = { hashify( $LEFT_PAREN, $RIGHT_PAREN ) };
196              
197 277         694 my $previous_token = $elem->previous_token();
198 277   100     9620 while (
      66        
199             $previous_token
200             and (
201             not $previous_token->significant()
202             or $is_paren->{$previous_token->content()}
203             )
204             ) {
205 240         1550 $previous_token = $previous_token->previous_token();
206             }
207              
208 277         7729 return $previous_token;
209             }
210              
211             1;
212              
213             __END__
214              
215             #-----------------------------------------------------------------------------
216              
217             =pod
218              
219             =head1 NAME
220              
221             Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros - Write C<oct(755)> instead of C<0755>.
222              
223              
224             =head1 AFFILIATION
225              
226             This Policy is part of the core L<Perl::Critic|Perl::Critic>
227             distribution.
228              
229              
230             =head1 DESCRIPTION
231              
232             Perl interprets numbers with leading zeros as octal. If that's what
233             you really want, its better to use C<oct> and make it obvious.
234              
235             $var = 041; # not ok, actually 33
236             $var = oct(41); # ok
237              
238             chmod 0644, $file; # ok by default
239             dbmopen %database, 'foo.db', 0600; # ok by default
240             mkdir $directory, 0755; # ok by default
241             sysopen $filehandle, $filename, O_RDWR, 0666; # ok by default
242             umask 0002; # ok by default
243              
244             use POSIX 'mkfifo';
245             mkfifo $fifo, 0600; # ok by default
246             POSIX::mkfifo $fifo, 0600; # ok by default
247              
248             =head1 CONFIGURATION
249              
250             If you want to ban all leading zeros, set C<strict> to a true value in
251             a F<.perlcriticrc> file.
252              
253             [ValuesAndExpressions::ProhibitLeadingZeros]
254             strict = 1
255              
256              
257             =head1 AUTHOR
258              
259             Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>
260              
261             =head1 COPYRIGHT
262              
263             Copyright (c) 2005-2023 Imaginative Software Systems. All rights reserved.
264              
265             This program is free software; you can redistribute it and/or modify
266             it under the same terms as Perl itself. The full text of this license
267             can be found in the LICENSE file included with this module.
268              
269             =cut
270              
271             # Local Variables:
272             # mode: cperl
273             # cperl-indent-level: 4
274             # fill-column: 78
275             # indent-tabs-mode: nil
276             # c-indentation-style: bsd
277             # End:
278             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :