vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.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::InputOutput::RequireBriefOpen;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13
  14 use Readonly;
  15
  16 use List::MoreUtils qw(any);
  17
  18 use Perl::Critic::Utils qw{ :severities :classification :booleans parse_arg_list };
  19 use base 'Perl::Critic::Policy';
  20
  21 our $VERSION = '1.088';
  22
  23 #-----------------------------------------------------------------------------
  24
  25 Readonly::Scalar my $DESC => q<Close filehandles as soon as possible after opening them>;
  26 Readonly::Scalar my $EXPL => [209];
  27
  28 Readonly::Scalar my $SCALAR_SIGIL => q<$>;  ## no critic (InterpolationOfLiterals)
  29 Readonly::Scalar my $GLOB_SIGIL   => q<*>;
  30
  31 #-----------------------------------------------------------------------------
  32
  33 sub supported_parameters {
  34     return (
  35         {
  36             name            => 'lines',
  37             description     => 'The maximum number of lines between an open() and a close().',
  38             default_string  => '9',
  39             behavior        => 'integer',
  40             integer_minimum => 1,
  41         },
  42     );
  43 }
  44
  45 sub default_severity     { return $SEVERITY_HIGH             }
  46 sub default_themes       { return qw< core pbp maintenance > }
  47 sub applies_to           { return 'PPI::Token::Word'         }
  48
  49 #-----------------------------------------------------------------------------
  50
  51 sub violates {
  52     my ( $self, $elem, undef ) = @_;
  53
  54     # Is it a call to open?
  55     return if $elem ne 'open';
  56     return if ! is_function_call($elem);
  57     my @open_args = parse_arg_list($elem);
  58     return if 2 > @open_args; # not a valid call to open()
  59
  60     my ($is_lexical, $fh) = _get_opened_fh($open_args[0]);
  61     return if not $fh;
  62     return if $fh =~ m< \A [*]? STD (?: IN|OUT|ERR ) \z >xms;
  63
  64     for my $close_token ($self->_find_close_invocations_or_return($elem)) {
  65         # The $close_token might be a close() or a return()
  66         #  It doesn't matter which -- both satisfy this policy
  67         if (is_function_call($close_token)) {
  68             my @close_args = parse_arg_list($close_token);
  69
  70             my $close_parameter = $close_args[0];
  71             if ('ARRAY' eq ref $close_parameter) {
  72                 $close_parameter = ${$close_parameter}[0];
  73             }
  74             if ( $close_parameter ) {
  75                 $close_parameter = "$close_parameter";
  76                 return if $fh eq $close_parameter;
  77
  78                 if ( any { m< \A [*] >xms } ($fh, $close_parameter) ) {
  79                     (my $stripped_fh = $fh) =~ s< \A [*] ><>xms;
  80                     (my $stripped_parameter = $close_parameter) =~
  81                         s< \A [*] ><>xms;
  82
  83                     return if $stripped_fh eq $stripped_parameter;
  84                 }
  85             }
  86         }
  87         elsif ($is_lexical && is_method_call($close_token)) {
  88             my $tok = $close_token->sprevious_sibling->sprevious_sibling;
  89             return if $fh eq $tok;
  90         }
  91     }
  92
  93     return $self->violation( $DESC, $EXPL, $elem );
  94 }
  95
  96 sub _find_close_invocations_or_return {
  97     my ($self, $elem) = @_;
  98
  99     my $parent = _get_scope($elem);
 100     return if !$parent; # I can't think of a scenario where this would happen
 101
 102     my $open_loc = $elem->location;
 103     # we don't actually allow _lines to be zero or undef, but maybe we will
 104     my $end_line = $self->{_lines} ? $open_loc->[0] + $self->{_lines} : undef;
 105
 106     my $closes = $parent->find(sub {
 107         ##no critic (ProhibitExplicitReturnUndef)
 108         my ($parent, $candidate) = @_;
 109         return undef if $candidate->isa('PPI::Statement::Sub');
 110         my $candidate_loc = $candidate->location;
 111         return undef if !defined $candidate_loc->[0];
 112         return 0 if $candidate_loc->[0] < $open_loc->[0];
 113         return 0 if $candidate_loc->[0] == $open_loc->[0] && $candidate_loc->[1] <= $open_loc->[1];
 114         return undef if defined $end_line && $candidate_loc->[0] > $end_line;
 115         return 0 if !$candidate->isa('PPI::Token::Word');
 116         return 1 if $candidate eq 'close' || $candidate eq 'return';
 117         return 0;
 118     });
 119     return @{$closes || []};
 120 }
 121
 122 sub _get_scope {
 123     my ($elem) = @_;
 124
 125     while ($elem = $elem->parent) {
 126         return $elem if $elem->scope;
 127     }
 128     return;  # should never happen if we are in a PPI::Document
 129 }
 130
 131 sub _get_opened_fh {
 132     my ($tokens) = shift;
 133
 134     my $is_lexical;
 135     my $fh;
 136
 137     if ( 2 == @{$tokens} ) {
 138         if ('my' eq $tokens->[0] &&
 139             $tokens->[1]->isa('PPI::Token::Symbol') &&
 140             $SCALAR_SIGIL eq $tokens->[1]->raw_type) {
 141
 142             $is_lexical = 1;
 143             $fh = $tokens->[1];
 144         }
 145     }
 146     elsif (1 == @{$tokens}) {
 147         my $argument = _unwrap_block( $tokens->[0] );
 148         if ( $argument->isa('PPI::Token::Symbol') ) {
 149             my $sigil = $argument->raw_type();
 150             if ($SCALAR_SIGIL eq $sigil) {
 151                 $is_lexical = 1;
 152                 $fh = $argument;
 153             }
 154             elsif ($GLOB_SIGIL eq $sigil) {
 155                 $is_lexical = 0;
 156                 $fh = $argument;
 157             }
 158         }
 159         elsif ($argument->isa('PPI::Token::Word') && $argument eq uc $argument) {
 160             $is_lexical = 0;
 161             $fh = $argument;
 162         }
 163     }
 164
 165     return ($is_lexical, $fh);
 166 }
 167
 168 sub _unwrap_block {
 169     my ($element) = @_;
 170
 171     return $element if not $element->isa('PPI::Structure::Block');
 172
 173     my @children = $element->schildren();
 174     return $element if 1 != @children;
 175     my $child = $children[0];
 176
 177     return $child if not $child->isa('PPI::Statement');
 178
 179     my @grandchildren = $child->schildren();
 180     return $element if 1 != @grandchildren;
 181
 182     return $grandchildren[0];
 183 }
 184
 185 1;
 186
 187 __END__
 188
 189 #-----------------------------------------------------------------------------
 190
 191 =pod
 192
 193 =for stopwords redeclared
 194
 195 =head1 NAME
 196
 197 Perl::Critic::Policy::InputOutput::RequireBriefOpen - Close filehandles as soon as possible after opening them.
 198
 199
 200 =head1 AFFILIATION
 201
 202 This Policy is part of the core L<Perl::Critic> distribution.
 203
 204
 205 =head1 DESCRIPTION
 206
 207 One way that production systems fail unexpectedly is by running out of
 208 filehandles.  Filehandles are a finite resource on every operating system that
 209 I'm aware of, and running out of them is virtually impossible to recover from.
 210 The solution is to not run out in the first place.  What causes programs to
 211 run out of filehandles?  Usually, it's leaks: you open a filehandle and forget
 212 to close it, or just wait a really long time before closing it.
 213
 214 This problem is rarely exposed by test systems, because the tests rarely run
 215 long enough or have enough load to hit the filehandle limit.  So, the best way
 216 to avoid the problem is 1) always close all filehandles that you open and 2)
 217 close them as soon as is practical.
 218
 219 This policy takes note of calls to C<open()> where there is no matching
 220 C<close()> call within C<N> lines of code.  If you really need to do a lot of
 221 processing on an open filehandle, then you can move that processing to another
 222 method like this:
 223
 224     sub process_data_file {
 225         my ($self, $filename) = @_;
 226         open my $fh, '<', $filename
 227             or croak 'Failed to read datafile ' .  $filename . '; ' . $OS_ERROR;
 228         $self->_parse_input_data($fh);
 229         close $fh;
 230         return;
 231     }
 232     sub _parse_input_data {
 233         my ($self, $fh) = @_;
 234         while (my $line = <$fh>) {
 235             ...
 236         }
 237         return;
 238     }
 239
 240 As a special case, this policy also allows code to return the filehandle after
 241 the C<open> instead of closing it.  Just like the close, however, that
 242 C<return> has to be within the right number of lines.  From there, you're on
 243 your own to figure out whether the code is promptly closing the filehandle.
 244
 245 The STDIN, STDOUT, and STDERR handles are exempt from this policy.
 246
 247
 248 =head1 CONFIGURATION
 249
 250 This policy allows C<close()> invocations to be up to C<N> lines after their
 251 corresponding C<open()> calls, where C<N> defaults to 9.  You can override
 252 this to set it to a different number with the C<lines> setting.  To do this,
 253 put entries in a F<.perlcriticrc> file like this:
 254
 255   [InputOutput::RequireBriefOpen]
 256   lines = 5
 257
 258
 259 =head1 CAVEATS
 260
 261 =head2 C<IO::File-E<gt>new>
 262
 263 This policy only looks for explicit C<open> calls.  It does not detect calls
 264 to C<CORE::open> or C<IO::File-E<gt>new> or the like.
 265
 266
 267 =head2 Is it the right lexical?
 268
 269 We don't currently check for redeclared filehandles.  So the following code
 270 is false negative, for example, because the outer scoped filehandle is not closed:
 271
 272     open my $fh, '<', $file1 or croak;
 273     if (open my $fh, '<', $file2) {
 274         print <$fh>;
 275         close $fh;
 276     }
 277
 278 This is a contrived example, but it isn't uncommon for people to use C<$fh>
 279 for the name of the filehandle every time.  Perhaps it's time to think of
 280 better variable names...
 281
 282
 283 =head1 CREDITS
 284
 285 Initial development of this policy was supported by a grant from the Perl Foundation.
 286
 287
 288 =head1 AUTHOR
 289
 290 Chris Dolan <cdolan@cpan.org>
 291
 292
 293 =head1 COPYRIGHT
 294
 295 Copyright (c) 2007-2008 Chris Dolan.  Many rights reserved.
 296
 297 This program is free software; you can redistribute it and/or modify
 298 it under the same terms as Perl itself.  The full text of this license
 299 can be found in the LICENSE file included with this module
 300
 301 =cut
 302
 303 # Local Variables:
 304 #   mode: cperl
 305 #   cperl-indent-level: 4
 306 #   fill-column: 78
 307 #   indent-tabs-mode: nil
 308 #   c-indentation-style: bsd
 309 # End:
 310 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :