X-Git-Url: http://git.maemo.org/git/?p=dh-make-perl;a=blobdiff_plain;f=dev%2Fi386%2Flibperl-critic-perl%2Flibperl-critic-perl-1.088%2Flib%2FPerl%2FCritic%2FPolicy%2FSubroutines%2FRequireArgUnpacking.pm;fp=dev%2Fi386%2Flibperl-critic-perl%2Flibperl-critic-perl-1.088%2Flib%2FPerl%2FCritic%2FPolicy%2FSubroutines%2FRequireArgUnpacking.pm;h=fb7f48951d729b0655a489c9bb5e2c26d3dd97a1;hp=0000000000000000000000000000000000000000;hb=da95c414033799c3a62606f299c3c00b5c77ca11;hpb=2d38e14bacbb15b98e539843a40b3c52a225f493 diff --git a/dev/i386/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm b/dev/i386/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm new file mode 100644 index 0000000..fb7f489 --- /dev/null +++ b/dev/i386/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm @@ -0,0 +1,242 @@ +############################################################################## +# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm $ +# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $ +# $Author: clonezone $ +# $Revision: 2489 $ +############################################################################## + +package Perl::Critic::Policy::Subroutines::RequireArgUnpacking; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use File::Spec; +use List::Util qw(first); +use List::MoreUtils qw(uniq any); +use English qw(-no_match_vars); +use Carp; + +use Perl::Critic::Utils qw{ :severities words_from_string }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.088'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $AT => q{@}; ##no critic(Interpolation) +Readonly::Scalar my $AT_ARG => q{@_}; ##no critic(Interpolation) + +Readonly::Scalar my $DESC => qq{Always unpack $AT_ARG first}; +Readonly::Scalar my $EXPL => [178]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'short_subroutine_statements', + description => + 'The number of statements to allow without unpacking.', + default_string => '0', + behavior => 'integer', + integer_minimum => 0, + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # forward declaration? + return if !$elem->block; + + my @statements = $elem->block->schildren; + + # empty sub? + return if !@statements; + + # Don't apply policy to short subroutines + + # Should we instead be doing a find() for PPI::Statement + # instances? That is, should we count all statements instead of + # just top-level statements? + return if $self->{_short_subroutine_statements} >= @statements; + + # look for explicit dereferences of @_, including '$_[0]' + # You may use "... = @_;" in the first paragraph of the sub + # Don't descend into nested or anonymous subs + my $state = 'unpacking'; # still in unpacking paragraph + for my $statement (@statements) { + + my @magic = _get_arg_symbols($statement); + + my $saw_unpack = 0; + MAGIC: + for my $magic (@magic) { + if ($AT eq $magic->raw_type) { # this is '@_', not '$_[0]' + my $prev = $magic->sprevious_sibling; + my $next = $magic->snext_sibling; + + # allow conditional checks on the size of @_ + next MAGIC if _is_size_check($magic); + + if ('unpacking' eq $state) { + if (_is_unpack($magic)) { + $saw_unpack = 1; + next MAGIC; + } + } + } + return $self->violation( $DESC, $EXPL, $elem ); + } + if (!$saw_unpack) { + $state = 'post_unpacking'; + } + } + return; # OK +} + +sub _is_unpack { + my ($magic) = @_; + + my $prev = $magic->sprevious_sibling; + my $next = $magic->snext_sibling; + + return 1 if ($prev && $prev->isa('PPI::Token::Operator') && q{=} eq $prev && + (!$next || ($next->isa('PPI::Token::Structure') && q{;} eq $next))); + return; +} + +sub _is_size_check { + my ($magic) = @_; + + my $prev = $magic->sprevious_sibling; + my $next = $magic->snext_sibling; + + return 1 if !$next && $prev && $prev->isa('PPI::Token::Operator') && + (q{==} eq $prev || q{!=} eq $prev); + return 1 if !$prev && $next && $next->isa('PPI::Token::Operator') && + (q{==} eq $next || q{!=} eq $next); + return; +} + +sub _get_arg_symbols { + my ($statement) = @_; + + return grep {$AT_ARG eq $_->symbol} @{$statement->find(\&_magic_finder) || []}; +} + +sub _magic_finder { + # Find all @_ and $_[\d+] not inside of nested subs + my (undef, $elem) = @_; + return 1 if $elem->isa('PPI::Token::Magic'); # match + + if ($elem->isa('PPI::Structure::Block')) { + # don't descend into a nested named sub + return if $elem->statement->isa('PPI::Statement::Sub'); + + my $prev = $elem->sprevious_sibling; + # don't descend into a nested anon sub block + return if $prev && $prev->isa('PPI::Token::Word') && 'sub' eq $prev; + } + + return 0; # no match, descend +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::RequireArgUnpacking - Always unpack C<@_> first. + +=head1 AFFILIATION + +This Policy is part of the core L distribution. + + +=head1 DESCRIPTION + +Subroutines that use C<@_> directly instead of unpacking the arguments to +local variables first have two major problems. First, they are very hard to +read. If you're going to refer to your variables by number instead of by +name, you may as well be writing assembler code! Second, C<@_> contains +aliases to the original variables! If you modify the contents of a C<@_> +entry, then you are modifying the variable outside of your subroutine. For +example: + + sub print_local_var_plus_one { + my ($var) = @_; + print ++$var; + } + sub print_var_plus_one { + print ++$_[0]; + } + + my $x = 2; + print_local_var_plus_one($x); # prints "3", $x is still 2 + print_var_plus_one($x); # prints "3", $x is now 3 ! + print $x; # prints "3" + +This is spooky action-at-a-distance and is very hard to debug if it's not +intentional and well-documented (like C or C). + +=head1 CONFIGURATION + +This policy is lenient for subroutines which have C or fewer top-level +statements, where C defaults to ZERO. You can override this to set it to a +higher number with the C setting. This is very +much not recommended but perhaps you REALLY need high performance. To do +this, put entries in a F<.perlcriticrc> file like this: + + [Subroutines::RequireArgUnpacking] + short_subroutine_statements = 2 + +=head1 CAVEATS + +PPI doesn't currently detect anonymous subroutines, so we don't check those. +This should just work when PPI gains that feature. + +We don't check for C<@ARG>, the alias for C<@_> from English.pm. That's +deprecated anyway. + +=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 :