git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.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::Subroutines::RequireFinalReturn;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use Readonly;
  14
  15 use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
  16 use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
  17 use base 'Perl::Critic::Policy';
  18
  19 our $VERSION = '1.088';
  20
  21 #-----------------------------------------------------------------------------
  22
  23 Readonly::Scalar my $DESC => q{Subroutine does not end with "return"};
  24 Readonly::Scalar my $EXPL => [ 197 ];
  25
  26 Readonly::Hash my %CONDITIONALS => hashify( qw(if unless for foreach) );
  27
  28 #-----------------------------------------------------------------------------
  29
  30 sub supported_parameters {
  31     return (
  32         {
  33             name            => 'terminal_funcs',
  34             description     => 'The additional subroutines to treat as terminal.',
  35             default_string  => $EMPTY,
  36             behavior        => 'string list',
  37             list_always_present_values =>
  38                 [ qw( exit die croak confess throw Carp::confess Carp::croak ) ],
  39         },
  40     );
  41 }
  42
  43 sub default_severity { return $SEVERITY_HIGH        }
  44 sub default_themes   { return qw( core bugs pbp )   }
  45 sub applies_to       { return 'PPI::Statement::Sub' }
  46
  47 #-----------------------------------------------------------------------------
  48
  49 sub violates {
  50     my ( $self, $elem, undef ) = @_;
  51
  52     # skip BEGIN{} and INIT{} and END{} etc
  53     return if $elem->isa('PPI::Statement::Scheduled');
  54
  55     my @blocks = grep {$_->isa('PPI::Structure::Block')} $elem->schildren();
  56     if (@blocks > 1) {
  57        # sanity check
  58        throw_internal 'Subroutine should have no more than one block';
  59     }
  60     elsif (@blocks == 0) {
  61        #Technically, subroutines don't have to have a block at all. In
  62        # that case, its just a declaration so this policy doesn't really apply
  63        return; # ok!
  64     }
  65
  66
  67     my ($block) = @blocks;
  68     if ($self->_block_is_empty($block) || $self->_block_has_return($block)) {
  69         return; # OK
  70     }
  71
  72     # Must be a violation
  73     return $self->violation( $DESC, $EXPL, $elem );
  74 }
  75
  76 #-----------------------------------------------------------------------------
  77
  78 sub _block_is_empty {
  79     my ( $self, $block ) = @_;
  80     return $block->schildren() == 0;
  81 }
  82
  83 #-----------------------------------------------------------------------------
  84
  85 sub _block_has_return {
  86     my ( $self, $block ) = @_;
  87     my @blockparts = $block->schildren();
  88     my $final = $blockparts[-1]; # always defined because we call _block_is_empty first
  89     return if !$final;
  90     return $self->_is_explicit_return($final)
  91         || $self->_is_compound_return($final);
  92 }
  93
  94 #-----------------------------------------------------------------------------
  95
  96 sub _is_explicit_return {
  97     my ( $self, $final ) = @_;
  98
  99     return if $self->_is_conditional_stmnt( $final );
 100     return $self->_is_return_or_goto_stmnt( $final )
 101         || $self->_is_terminal_stmnt( $final );
 102 }
 103
 104 #-----------------------------------------------------------------------------
 105
 106 sub _is_compound_return {
 107     my ( $self, $final ) = @_;
 108
 109     if (!$final->isa('PPI::Statement::Compound')) {
 110         return; #fail
 111     }
 112
 113     my $begin = $final->schild(0);
 114     return if !$begin; #fail
 115     if (!($begin->isa('PPI::Token::Word') &&
 116           ($begin eq 'if' || $begin eq 'unless'))) {
 117         return; #fail
 118     }
 119
 120     my @blocks = grep {!$_->isa('PPI::Structure::Condition') &&
 121                        !$_->isa('PPI::Token')} $final->schildren();
 122     # Sanity check:
 123     if (scalar grep {!$_->isa('PPI::Structure::Block')} @blocks) {
 124         throw_internal
 125             'Expected only conditions, blocks and tokens in the if statement';
 126     }
 127
 128     for my $block (@blocks) {
 129         if (! $self->_block_has_return($block)) {
 130             return; #fail
 131         }
 132     }
 133
 134     return 1;
 135 }
 136
 137 #-----------------------------------------------------------------------------
 138
 139 sub _is_return_or_goto_stmnt {
 140     my ( $self, $stmnt ) = @_;
 141     return if not $stmnt->isa('PPI::Statement::Break');
 142     my $first_token = $stmnt->schild(0) || return;
 143     return $first_token eq 'return' || $first_token eq 'goto';
 144 }
 145
 146 #-----------------------------------------------------------------------------
 147
 148 sub _is_terminal_stmnt {
 149     my ( $self, $stmnt ) = @_;
 150     return if not $stmnt->isa('PPI::Statement');
 151     my $first_token = $stmnt->schild(0) || return;
 152     return exists $self->{_terminal_funcs}->{$first_token};
 153 }
 154
 155 #-----------------------------------------------------------------------------
 156
 157 sub _is_conditional_stmnt {
 158     my ( $self, $stmnt ) = @_;
 159     return if not $stmnt->isa('PPI::Statement');
 160     for my $elem ( $stmnt->schildren() ) {
 161         return 1 if $elem->isa('PPI::Token::Word')
 162             && exists $CONDITIONALS{$elem};
 163     }
 164     return;
 165 }
 166
 167 1;
 168
 169 __END__
 170
 171 #-----------------------------------------------------------------------------
 172
 173 =pod
 174
 175 =head1 NAME
 176
 177 Perl::Critic::Policy::Subroutines::RequireFinalReturn - End every path through a subroutine with an explicit C<return> statement.
 178
 179 =head1 AFFILIATION
 180
 181 This Policy is part of the core L<Perl::Critic> distribution.
 182
 183
 184 =head1 DESCRIPTION
 185
 186 Require all subroutines to terminate explicitly with one of the following:
 187 C<return>, C<goto>, C<die>, C<exit>, C<throw>, C<carp> or C<croak>.
 188
 189 Subroutines without explicit return statements at their ends can be confusing.
 190 It can be challenging to deduce what the return value will be.
 191
 192 Furthermore, if the programmer did not mean for there to be a significant
 193 return value, and omits a return statement, some of the subroutine's inner
 194 data can leak to the outside.  Consider this case:
 195
 196    package Password;
 197    # every time the user guesses the password wrong, its value
 198    # is rotated by one character
 199    my $password;
 200    sub set_password {
 201       $password = shift;
 202    }
 203    sub check_password {
 204       my $guess = shift;
 205       if ($guess eq $password) {
 206          unlock_secrets();
 207       } else {
 208          $password = (substr $password, 1).(substr $password, 0, 1);
 209       }
 210    }
 211    1;
 212
 213 In this case, the last statement in check_password() is the assignment.  The
 214 result of that assignment is the implicit return value, so a wrong guess
 215 returns the right password!  Adding a C<return;> at the end of that subroutine
 216 solves the problem.
 217
 218 The only exception allowed is an empty subroutine.
 219
 220 Be careful when fixing problems identified by this Policy; don't blindly put
 221 a C<return;> statement at the end of every subroutine.
 222
 223 =head1 CONFIGURATION
 224
 225 If you've created your own terminal functions that behave like C<die> or
 226 C<exit>, then you can configure Perl::Critic to recognize those functions as
 227 well.  Just put something like this in your F<.perlcriticrc>:
 228
 229   [Subroutines::RequireFinalReturns]
 230   terminal_funcs = quit abort bailout
 231
 232 =head1 LIMITATIONS
 233
 234 We do not look for returns inside ternary operators.  That
 235 construction is too complicated to analyze right now.  Besides, a
 236 better form is the return outside of the ternary like this: C<return
 237 foo ? 1 : bar ? 2 : 3>
 238
 239 =head1 AUTHOR
 240
 241 Chris Dolan <cdolan@cpan.org>
 242
 243 =head1 COPYRIGHT
 244
 245 Copyright (c) 2005-2008 Chris Dolan.  All rights reserved.
 246
 247 This program is free software; you can redistribute it and/or modify
 248 it under the same terms as Perl itself.  The full text of this license
 249 can be found in the LICENSE file included with this module.
 250
 251 =cut
 252
 253 ##############################################################################
 254 # Local Variables:
 255 #   mode: cperl
 256 #   cperl-indent-level: 4
 257 #   fill-column: 78
 258 #   indent-tabs-mode: nil
 259 #   c-indentation-style: bsd
 260 # End:
 261 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :