X-Git-Url: http://git.maemo.org/git/?p=dh-make-perl;a=blobdiff_plain;f=dev%2Farm%2Flibperl-critic-perl%2Flibperl-critic-perl-1.088%2Flib%2FPerl%2FCritic%2FPolicy%2FInputOutput%2FRequireBriefOpen.pm;fp=dev%2Farm%2Flibperl-critic-perl%2Flibperl-critic-perl-1.088%2Flib%2FPerl%2FCritic%2FPolicy%2FInputOutput%2FRequireBriefOpen.pm;h=5ff8c5b979565345d9d6ce2d9b6a450bb2e4cd9e;hp=0000000000000000000000000000000000000000;hb=f477fa73365d491991707e7ed9217b48d6994551;hpb=da95c414033799c3a62606f299c3c00b5c77ca11 diff --git a/dev/arm/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm b/dev/arm/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm new file mode 100644 index 0000000..5ff8c5b --- /dev/null +++ b/dev/arm/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm @@ -0,0 +1,310 @@ +############################################################################## +# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm $ +# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $ +# $Author: clonezone $ +# $Revision: 2489 $ +############################################################################## + +package Perl::Critic::Policy::InputOutput::RequireBriefOpen; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use List::MoreUtils qw(any); + +use Perl::Critic::Utils qw{ :severities :classification :booleans parse_arg_list }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.088'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => [209]; + +Readonly::Scalar my $SCALAR_SIGIL => q<$>; ## no critic (InterpolationOfLiterals) +Readonly::Scalar my $GLOB_SIGIL => q<*>; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'lines', + description => 'The maximum number of lines between an open() and a close().', + default_string => '9', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw< core pbp maintenance > } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # Is it a call to open? + return if $elem ne 'open'; + return if ! is_function_call($elem); + my @open_args = parse_arg_list($elem); + return if 2 > @open_args; # not a valid call to open() + + my ($is_lexical, $fh) = _get_opened_fh($open_args[0]); + return if not $fh; + return if $fh =~ m< \A [*]? STD (?: IN|OUT|ERR ) \z >xms; + + for my $close_token ($self->_find_close_invocations_or_return($elem)) { + # The $close_token might be a close() or a return() + # It doesn't matter which -- both satisfy this policy + if (is_function_call($close_token)) { + my @close_args = parse_arg_list($close_token); + + my $close_parameter = $close_args[0]; + if ('ARRAY' eq ref $close_parameter) { + $close_parameter = ${$close_parameter}[0]; + } + if ( $close_parameter ) { + $close_parameter = "$close_parameter"; + return if $fh eq $close_parameter; + + if ( any { m< \A [*] >xms } ($fh, $close_parameter) ) { + (my $stripped_fh = $fh) =~ s< \A [*] ><>xms; + (my $stripped_parameter = $close_parameter) =~ + s< \A [*] ><>xms; + + return if $stripped_fh eq $stripped_parameter; + } + } + } + elsif ($is_lexical && is_method_call($close_token)) { + my $tok = $close_token->sprevious_sibling->sprevious_sibling; + return if $fh eq $tok; + } + } + + return $self->violation( $DESC, $EXPL, $elem ); +} + +sub _find_close_invocations_or_return { + my ($self, $elem) = @_; + + my $parent = _get_scope($elem); + return if !$parent; # I can't think of a scenario where this would happen + + my $open_loc = $elem->location; + # we don't actually allow _lines to be zero or undef, but maybe we will + my $end_line = $self->{_lines} ? $open_loc->[0] + $self->{_lines} : undef; + + my $closes = $parent->find(sub { + ##no critic (ProhibitExplicitReturnUndef) + my ($parent, $candidate) = @_; + return undef if $candidate->isa('PPI::Statement::Sub'); + my $candidate_loc = $candidate->location; + return undef if !defined $candidate_loc->[0]; + return 0 if $candidate_loc->[0] < $open_loc->[0]; + return 0 if $candidate_loc->[0] == $open_loc->[0] && $candidate_loc->[1] <= $open_loc->[1]; + return undef if defined $end_line && $candidate_loc->[0] > $end_line; + return 0 if !$candidate->isa('PPI::Token::Word'); + return 1 if $candidate eq 'close' || $candidate eq 'return'; + return 0; + }); + return @{$closes || []}; +} + +sub _get_scope { + my ($elem) = @_; + + while ($elem = $elem->parent) { + return $elem if $elem->scope; + } + return; # should never happen if we are in a PPI::Document +} + +sub _get_opened_fh { + my ($tokens) = shift; + + my $is_lexical; + my $fh; + + if ( 2 == @{$tokens} ) { + if ('my' eq $tokens->[0] && + $tokens->[1]->isa('PPI::Token::Symbol') && + $SCALAR_SIGIL eq $tokens->[1]->raw_type) { + + $is_lexical = 1; + $fh = $tokens->[1]; + } + } + elsif (1 == @{$tokens}) { + my $argument = _unwrap_block( $tokens->[0] ); + if ( $argument->isa('PPI::Token::Symbol') ) { + my $sigil = $argument->raw_type(); + if ($SCALAR_SIGIL eq $sigil) { + $is_lexical = 1; + $fh = $argument; + } + elsif ($GLOB_SIGIL eq $sigil) { + $is_lexical = 0; + $fh = $argument; + } + } + elsif ($argument->isa('PPI::Token::Word') && $argument eq uc $argument) { + $is_lexical = 0; + $fh = $argument; + } + } + + return ($is_lexical, $fh); +} + +sub _unwrap_block { + my ($element) = @_; + + return $element if not $element->isa('PPI::Structure::Block'); + + my @children = $element->schildren(); + return $element if 1 != @children; + my $child = $children[0]; + + return $child if not $child->isa('PPI::Statement'); + + my @grandchildren = $child->schildren(); + return $element if 1 != @grandchildren; + + return $grandchildren[0]; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords redeclared + +=head1 NAME + +Perl::Critic::Policy::InputOutput::RequireBriefOpen - Close filehandles as soon as possible after opening them. + + +=head1 AFFILIATION + +This Policy is part of the core L distribution. + + +=head1 DESCRIPTION + +One way that production systems fail unexpectedly is by running out of +filehandles. Filehandles are a finite resource on every operating system that +I'm aware of, and running out of them is virtually impossible to recover from. +The solution is to not run out in the first place. What causes programs to +run out of filehandles? Usually, it's leaks: you open a filehandle and forget +to close it, or just wait a really long time before closing it. + +This problem is rarely exposed by test systems, because the tests rarely run +long enough or have enough load to hit the filehandle limit. So, the best way +to avoid the problem is 1) always close all filehandles that you open and 2) +close them as soon as is practical. + +This policy takes note of calls to C where there is no matching +C call within C lines of code. If you really need to do a lot of +processing on an open filehandle, then you can move that processing to another +method like this: + + sub process_data_file { + my ($self, $filename) = @_; + open my $fh, '<', $filename + or croak 'Failed to read datafile ' . $filename . '; ' . $OS_ERROR; + $self->_parse_input_data($fh); + close $fh; + return; + } + sub _parse_input_data { + my ($self, $fh) = @_; + while (my $line = <$fh>) { + ... + } + return; + } + +As a special case, this policy also allows code to return the filehandle after +the C instead of closing it. Just like the close, however, that +C has to be within the right number of lines. From there, you're on +your own to figure out whether the code is promptly closing the filehandle. + +The STDIN, STDOUT, and STDERR handles are exempt from this policy. + + +=head1 CONFIGURATION + +This policy allows C invocations to be up to C lines after their +corresponding C calls, where C defaults to 9. You can override +this to set it to a different number with the C setting. To do this, +put entries in a F<.perlcriticrc> file like this: + + [InputOutput::RequireBriefOpen] + lines = 5 + + +=head1 CAVEATS + +=head2 Cnew> + +This policy only looks for explicit C calls. It does not detect calls +to C or Cnew> or the like. + + +=head2 Is it the right lexical? + +We don't currently check for redeclared filehandles. So the following code +is false negative, for example, because the outer scoped filehandle is not closed: + + open my $fh, '<', $file1 or croak; + if (open my $fh, '<', $file2) { + print <$fh>; + close $fh; + } + +This is a contrived example, but it isn't uncommon for people to use C<$fh> +for the name of the filehandle every time. Perhaps it's time to think of +better variable names... + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2008 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :