vcs.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm

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