Login
Added new policy: ProhibitReturnSort, as suggested by Ulrich Wisser.
authorJeffrey Ryan Thalhammer <jeff@imaginative-software.com>
Mon, 24 Nov 2008 05:06:47 +0000 (05:06 +0000)
committerJeffrey Ryan Thalhammer <jeff@imaginative-software.com>
Mon, 24 Nov 2008 05:06:47 +0000 (05:06 +0000)
I hadn't anticipated the problem with false-positives due to wantarray().
I don't know if this issue is a release-blocker.  What do you think?

Changes
lib/Perl/Critic/Policy.pm
lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm [new file with mode: 0644]
lib/Perl/Critic/PolicyFactory.pm
lib/Perl/Critic/TestUtils.pm
t/Subroutines/ProhibitReturnSort.run [new file with mode: 0644]

diff --git a/Changes b/Changes
index 969e9ba..3e4cee4 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,8 +1,19 @@
 [1.xxx] Released on 2008-xx-xx
 
+    Policy Changes:
     * InputOutput::RequireCheckedSyscalls now has an exclude_functions
       parameter.
 
+    New Policies:
+    * Miscellanea::ProhibitUselessNoCritic
+    * Subroutines::ProhibitReturnSort
+    
+    Miscellanea:
+    Perl::Critic::Violation will automatically strip trailing periods 
+    from your Policy description and explanation strings.  This
+    ensures that the punctuation is consistent with the format
+    specified by the user via the -verbose formatting options.
+    
 [1.093_02] Released on 2008-10-30
 
     Being released right now simply so that I can put out a version of
@@ -50,7 +61,6 @@
     New Policies:
     * NamingConventions::Capitalization
     * Miscellanea::ProhibitUnrestrictedNoCritic
-    * Miscellanea::ProhibitUselessNoCritic
     * Variables::ProhibitReusedNames
 
 [1.093_01] Released on 2008-09-07
index 26d669f..18b525e 100644 (file)
@@ -343,8 +343,9 @@ sub set_themes {
 
 sub get_themes {
     my ($self) = @_;
-    return sort @{ $self->{_themes} } if defined $self->{_themes};
-    return sort $self->default_themes();
+    my @themes = defined $self->{_themes} ? @{ $self->{_themes} } : $self->default_themes();
+    my @sorted_themes = sort @themes;
+    return @sorted_themes;
 }
 
 #-----------------------------------------------------------------------------
diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm
new file mode 100644 (file)
index 0000000..f93ce6b
--- /dev/null
@@ -0,0 +1,132 @@
+##############################################################################
+#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm $
+#     $Date: 2008-10-30 09:20:47 -0700 (Thu, 30 Oct 2008) $
+#   $Author: clonezone $
+# $Revision: 2850 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitReturnSort;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.093_02';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{"return" statement followed by "sort"};
+Readonly::Scalar my $EXPL => q{Behavior is undefined if called in scalar context};
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return ()                 }
+sub default_severity     { return $SEVERITY_HIGHEST  }
+sub default_themes       { return qw(core bugs)      }
+sub applies_to           { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+    my ( $self, $elem, undef ) = @_;
+    return if ($elem ne 'return');
+    return if is_hash_key($elem);
+
+    my $sib = $elem->snext_sibling();
+    return if !$sib;
+    return if !$sib->isa('PPI::Token::Word');
+    return if $sib ne 'sort';
+
+    # Must be 'return sort'
+    return $self->violation( $DESC, $EXPL, $elem );
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords Ulrich Wisser
+
+=head1 NAME
+
+Perl::Critic::Policy::Subroutines::ProhibitReturnSort - Behavior of C<sort> is not defined if called in scalar context.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic|Perl::Critic>
+distribution.
+
+
+=head1 DESCRIPTION
+
+The behavior of the builtin C<sort> function is not defined if called
+in scalar context.  So if you write a subroutine that directly
+C<return>s the result of a C<sort> operation, then you code will
+behave unpredictably if someone calls your subroutine in a scalar
+context.  This Policy emits a violation if the C<return> keyword
+is directly followed by the C<sort> function.  To safely return a 
+sorted list of values from a subroutine, you should assign the 
+sorted values to a temporary variable first.  For example:
+
+   sub frobulate {
+       
+       return sort @list;  # not ok!
+       
+       @sorted_list = sort @list;
+       return @sort        # ok
+   }
+
+=head1 KNOWN BUGS
+
+This Policy is not sensitive to the C<wantarray> function.  So the
+following code would generate a false violation:
+
+   sub frobulate {
+       
+       if (wantarray) {
+           return sort @list;
+       }
+       else{
+           return join @list;
+       }
+   }
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+=head1 CREDITS
+
+This Policy was suggested by Ulrich Wisser and the L<http://iis.se> team.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer.  All 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 :
index 585531d..b3f59a4 100644 (file)
@@ -229,7 +229,8 @@ sub create_all_policies {
 #-----------------------------------------------------------------------------
 
 sub site_policy_names {
-    return sort @site_policy_names;
+    my @sorted_policy_names = sort @site_policy_names;
+    return @sorted_policy_names;
 }
 
 #-----------------------------------------------------------------------------
index a9097d0..b37d38b 100644 (file)
@@ -289,7 +289,8 @@ sub bundled_policy_names {
     my $manifest = ExtUtils::Manifest::maniread();
     my @policy_paths = map {m{\A lib/(Perl/Critic/Policy/.*).pm \z}xms} keys %{$manifest};
     my @policies = map { join q{::}, split m{/}xms, $_} @policy_paths;
-    return sort @policies;
+    my @sorted_policies = sort @policies;
+    return @sorted_policies;
 }
 
 sub names_of_policies_willing_to_work {
diff --git a/t/Subroutines/ProhibitReturnSort.run b/t/Subroutines/ProhibitReturnSort.run
new file mode 100644 (file)
index 0000000..e8e3cc8
--- /dev/null
@@ -0,0 +1,55 @@
+## name simple failure
+## failures 6
+## cut
+
+sub test_sub1 {
+       return sort @list;
+       return sort(@list);
+}
+
+sub test_sub2 {
+    return sort { $a <=> $b } @list;
+    return sort({ $a <=> $b } @list);
+}
+
+sub test_sub3 {
+    return sort @list  if $bar;
+    return sort(@list) if $bar;
+}
+
+#-----------------------------------------------------------------------------
+## name simple success
+## failures 0
+## cut
+
+sub test_sub1 {
+       @sorted = sort @list;
+       return @sorted;
+}
+
+sub test_sub2 {
+       return wantarray ? sort @list : $foo;
+}
+
+sub test_sub3 {
+       return map {func($_)} sort @list;
+}
+
+#-----------------------------------------------------------------------------
+## name when used in conjunction with wantarray()
+## TODO False positive: used when when wantarray() has been consulted.
+## failures 0
+## cut
+
+sub test_sub1 {
+    if (wantarray) {
+        return sort @list;
+    }
+}
+
+#-----------------------------------------------------------------------------
+## name "sort" used in other contexts...
+## failures 0
+## cut
+$foo{sort}; # hash key, not keyword
+sub foo {return}; # no sibling