Login
Add autodie support to the InputOutput::RequireChecked* policies.
authorElliot Shank <perl@galumph.com>
Wed, 17 Sep 2008 03:46:23 +0000 (03:46 +0000)
committerElliot Shank <perl@galumph.com>
Wed, 17 Sep 2008 03:46:23 +0000 (03:46 +0000)
Changes
lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm
lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm
lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm
lib/Perl/Critic/Utils.pm
t/05_utils.t
t/InputOutput/RequireCheckedClose.run
t/InputOutput/RequireCheckedOpen.run
t/InputOutput/RequireCheckedSyscalls.run

diff --git a/Changes b/Changes
index 740b2b3..bd2f742 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,9 +1,11 @@
 [1.xxx] Released on 2008-xxx
 
     Policy Changes:
-    Modules::ProhibitEvilModules now allows you to specify what the
-    description of a use of a bad module should be, to, say, suggest that
-    people use autodie instead of Fatal.
+    * Modules::ProhibitEvilModules now allows you to specify what the
+      description of a use of a bad module should be, to, say, suggest that
+      people use autodie instead of Fatal.
+    * InputOutput::RequireCheckedClose, InputOutput::RequireCheckedOpen, and
+      InputOutput::RequireCheckedSyscalls now all support autodie.
 
 [1.093_01] Released on 2008-09-07
 
index 8e68f16..6ec9088 100644 (file)
@@ -67,9 +67,16 @@ failure. That value should be checked to ensure that the close was
 successful.
 
 
-  my $error = close $filehandle;                   # ok
-  close $filehandle or die "unable to close: $!";  # ok
-  close $filehandle;                               # not ok
+    my $error = close $filehandle;                   # ok
+    close $filehandle or die "unable to close: $!";  # ok
+    close $filehandle;                               # not ok
+
+    use autodie qw< :io >;
+    close $filehandle;                               # ok
+
+You can use L<autodie>, L<Fatal>, or L<Fatal::Exception> to get around
+this.  Currently, L<autodie> is not properly treated as a pragma; its
+lexical effects aren't taken into account.
 
 
 =head1 CONFIGURATION
index 428f946..be4800e 100644 (file)
@@ -67,9 +67,16 @@ failure. That value should always be checked to ensure that the open
 was successful.
 
 
-  my $error = open( $filehandle, $mode, $filename );                  # ok
-  open( $filehandle, $mode, $filename ) or die "unable to open: $!";  # ok
-  open( $filehandle, $mode, $filename );                              # not ok
+    my $error = open( $filehandle, $mode, $filename );                  # ok
+    open( $filehandle, $mode, $filename ) or die "unable to open: $!";  # ok
+    open( $filehandle, $mode, $filename );                              # not ok
+
+    use autodie;
+    open $filehandle, $mode, $filename;                                 # ok
+
+You can use L<autodie>, L<Fatal>, or L<Fatal::Exception> to get around
+this.  Currently, L<autodie> is not properly treated as a pragma; its
+lexical effects aren't taken into account.
 
 
 =head1 CONFIGURATION
index acc5f0f..4f02920 100644 (file)
@@ -123,9 +123,17 @@ If your module uses L<Fatal|Fatal> or C<Fatal::Exception>, then any
 functions wrapped by those modules will not trigger this policy.  For
 example:
 
-   use Fatal qw(open);
-   open my $fh, $filename;  # no violation
-   close $fh;               # yes violation
+    use Fatal qw(open);
+    open my $fh, $filename;  # no violation
+    close $fh;               # yes violation
+
+    use autodie;
+    open $filehandle, $mode, $filename;   # no violation
+
+You can use L<autodie>, L<Fatal>, or L<Fatal::Exception> to get around
+this.  Currently, L<autodie> is not properly treated as a pragma; its
+lexical effects aren't taken into account.
+
 
 =head1 CONFIGURATION
 
@@ -135,19 +143,19 @@ override this to set it to a different list of functions with the
 C<functions> setting.  To do this, put entries in a F<.perlcriticrc>
 file like this:
 
-  [InputOutput::RequireCheckedSyscalls]
-  functions = open opendir read readline readdir close closedir
+    [InputOutput::RequireCheckedSyscalls]
+    functions = open opendir read readline readdir close closedir
 
 We have defined a few shortcuts for creating this list
 
-  [InputOutput::RequireCheckedSyscalls]
-  functions = :defaults opendir readdir closedir
+    [InputOutput::RequireCheckedSyscalls]
+    functions = :defaults opendir readdir closedir
 
-  [InputOutput::RequireCheckedSyscalls]
-  functions = :builtins
+    [InputOutput::RequireCheckedSyscalls]
+    functions = :builtins
 
-  [InputOutput::RequireCheckedSyscalls]
-  functions = :all
+    [InputOutput::RequireCheckedSyscalls]
+    functions = :all
 
 The C<:builtins> shortcut above represents all of the builtin
 functions that have error conditions (about 65 of them, many of them
@@ -158,6 +166,7 @@ EVERY function call, even C<return> and C<exit>.  Yes, this "feature"
 is overkill and is wasting CPU cycles on your computer by just
 existing.  Nyah nyah.  I shouldn't code after midnight.
 
+
 =head1 CREDITS
 
 Initial development of this policy was supported by a grant from the
@@ -166,10 +175,12 @@ Perl Foundation.
 This policy module is based heavily on policies written by Andrew
 Moore <amoore@mooresystems.com>.
 
+
 =head1 AUTHOR
 
 Chris Dolan <cdolan@cpan.org>
 
+
 =head1 COPYRIGHT
 
 Copyright (c) 2007-2008 Chris Dolan.  Many rights reserved.
index bf11fb7..5f6d99e 100644 (file)
@@ -1125,28 +1125,139 @@ sub is_unchecked_call {
     return 1;
 }
 
+Readonly::Hash my %AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP => (
+    # Map builtins to themselves.
+    binmode    => { hashify(qw< binmode        >) },
+    close      => { hashify(qw< close          >) },
+    fcntl      => { hashify(qw< fcntl          >) },
+    fileno     => { hashify(qw< fileno         >) },
+    open       => { hashify(qw< open           >) },
+    sysopen    => { hashify(qw< sysopen        >) },
+    chdir      => { hashify(qw< chdir          >) },
+    opendir    => { hashify(qw< opendir        >) },
+    rename     => { hashify(qw< rename         >) },
+    unlink     => { hashify(qw< unlink         >) },
+    accept     => { hashify(qw< accept         >) },
+    bind       => { hashify(qw< bind           >) },
+    connect    => { hashify(qw< connect        >) },
+    getsockopt => { hashify(qw< getsockopt     >) },
+    listen     => { hashify(qw< listen         >) },
+    recv       => { hashify(qw< recv           >) },
+    send       => { hashify(qw< send           >) },
+    setsockopt => { hashify(qw< setsockopt     >) },
+    shutdown   => { hashify(qw< shutdown       >) },
+    socketpair => { hashify(qw< socketpair     >) },
+    fork       => { hashify(qw< fork           >) },
+    system     => { hashify(qw< system         >) },
+    exec       => { hashify(qw< exec           >) },
+
+    # Tags with immediate children.
+    ':file' => {
+        hashify(
+            qw<
+                binmode close fcntl fileno open sysopen
+            >
+        )
+    },
+    ':filesys' => {
+        hashify(
+            qw<
+                chdir opendir rename unlink
+            >
+        )
+    },
+    ':socket' => {
+        hashify(
+            qw<
+                accept bind connect getsockopt listen recv send setsockopt
+                shutdown socketpair
+            >
+        )
+    },
+    ':threads' => { hashify(qw< fork >) },
+    ':system'  => { hashify(qw< system exec >) },
+
+    # Tag with one level of tags below them.
+    ':io' => {
+        hashify(
+            qw<
+                binmode close fcntl fileno open sysopen chdir opendir rename
+                unlink accept bind connect getsockopt listen recv send
+                setsockopt shutdown socketpair
+            >
+        )
+    },
+
+    # Tag with two levels of tags below them.
+    ':default' => {
+        hashify(
+            qw<
+                binmode close fcntl fileno open sysopen chdir opendir rename
+                unlink accept bind connect getsockopt listen recv send
+                setsockopt shutdown socketpair fork
+            >
+        )
+    },
+
+    # The lot.
+    ':all' => {
+        hashify(
+            qw<
+                binmode close fcntl fileno open sysopen chdir opendir rename
+                unlink accept bind connect getsockopt listen recv send
+                setsockopt shutdown socketpair fork system exec
+            >
+        )
+    },
+);
+
 sub _is_fatal {
     my ($elem) = @_;
 
-    my $top = $elem->top;
-    return if !$top->isa('PPI::Document');
+    my $top = $elem->top();
+    return if not $top->isa('PPI::Document');
+
     my $includes = $top->find('PPI::Statement::Include');
-    return if !$includes;
+    return if not $includes;
+
     for my $include (@{$includes}) {
-        next if 'use' ne $include->type;
-        if ('Fatal' eq $include->module) {
+        next if 'use' ne $include->type();
+
+        if ('Fatal' eq $include->module()) {
             my @args = parse_arg_list($include->schild(1));
-            for my $arg (@args) {
-                return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string;
+            foreach my $arg (@args) {
+                return $TRUE if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string();
             }
-        } elsif ('Fatal::Exception' eq $include->module) {
+        }
+        elsif ('Fatal::Exception' eq $include->module()) {
             my @args = parse_arg_list($include->schild(1));
             shift @args;  # skip exception class name
-            for my $arg (@args) {
-                return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string;
+            foreach my $arg (@args) {
+                return $TRUE if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string();
+            }
+        }
+        elsif ('autodie' eq $include->pragma()) {
+            my @args = parse_arg_list($include->schild(1));
+
+            if (@args) {
+                foreach my $arg (@args) {
+                    my $builtins =
+                        $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{
+                            $arg->[0]->string
+                        };
+
+                    return $TRUE if $builtins and $builtins->{$elem->content()};
+                }
+            }
+            else {
+                my $builtins =
+                    $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{':default'};
+
+                return $TRUE if $builtins and $builtins->{$elem->content()};
             }
         }
     }
+
     return;
 }
 
index 5f2af4b..169793f 100644 (file)
@@ -23,7 +23,7 @@ use PPI::Document::File;
 use Perl::Critic::PolicyFactory;
 use Perl::Critic::TestUtils qw(bundled_policy_names);
 
-use Test::More tests => 116;
+use Test::More tests => 124;
 
 #-----------------------------------------------------------------------------
 
@@ -451,32 +451,83 @@ sub test_find_bundled_policies {
 sub test_is_unchecked_call {
     my @trials = (
         # just an obvious failure to check the return value
-        { code => q( open( $fh, $mode, $filename ); ),
-        pass => 1 },
+        {
+            code => q[ open( $fh, $mode, $filename ); ],
+            pass => 1,
+        },
         # check the value with a trailing conditional
-        { code => q( open( $fh, $mode, $filename ) or confess 'unable to open'; ),
-        pass => 0 },
+        {
+            code => q[ open( $fh, $mode, $filename ) or confess 'unable to open'; ],
+            pass => 0,
+        },
         # assign the return value to a variable (and assume that it's checked later)
-        { code => q( my $error = open( $fh, $mode, $filename ); ),
-        pass => 0 },
+        {
+            code => q[ my $error = open( $fh, $mode, $filename ); ],
+            pass => 0,
+        },
         # the system call is in a conditional
-        { code => q( return $EMPTY if not open my $fh, '<', $file; ),
-        pass => 0 },
+        {
+            code => q[ return $EMPTY if not open my $fh, '<', $file; ],
+            pass => 0,
+        },
         # open call in list context, checked with 'not'
-        { code => q( return $EMPTY if not ( open my $fh, '<', $file ); ),
-        pass => 0 },
+        {
+            code => q[ return $EMPTY if not ( open my $fh, '<', $file ); ],
+            pass => 0,
+        },
         # just putting the system call in a list context doesn't mean the return value is checked
-        { code => q( ( open my $fh, '<', $file ); ),
-        pass => 1 },
+        {
+            code => q[ ( open my $fh, '<', $file ); ],
+            pass => 1,
+        },
+
+        # Check Fatal.
+        {
+            code => q[ use Fatal qw< open >; open( $fh, $mode, $filename ); ],
+            pass => 0,
+        },
+        {
+            code => q[ use Fatal qw< open >; ( open my $fh, '<', $file ); ],
+            pass => 0,
+        },
+
+        # Check Fatal::Exception.
+        {
+            code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; open( $fh, $mode, $filename ); ],
+            pass => 0,
+        },
+        {
+            code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; ( open my $fh, '<', $file ); ],
+            pass => 0,
+        },
+
+        # Check autodie.
+        {
+            code => q[ use autodie; open( $fh, $mode, $filename ); ],
+            pass => 0,
+        },
+        {
+            code => q[ use autodie qw< :io >; open( $fh, $mode, $filename ); ],
+            pass => 0,
+        },
+        {
+            code => q[ use autodie qw< :system >; ( open my $fh, '<', $file ); ],
+            pass => 1,
+        },
+        {
+            code => q[ use autodie qw< :system :file >; ( open my $fh, '<', $file ); ],
+            pass => 0,
+        },
     );
 
     foreach my $trial ( @trials ) {
-        my $doc = make_doc( $trial->{'code'} );
+        my $code = $trial->{'code'};
+        my $doc = make_doc( $code );
         my $statement = $doc->find_first( sub { $_[1] eq 'open' } );
         if ( $trial->{'pass'} ) {
-            ok( is_unchecked_call( $statement ), 'is_unchecked_call returns true' );
+            ok( is_unchecked_call( $statement ), qq<is_unchecked_call returns true for "$code".> );
         } else {
-            ok( ! is_unchecked_call( $statement ), 'is_unchecked_call returns false' );
+            ok( ! is_unchecked_call( $statement ), qq<is_unchecked_call returns false for "$code".> );
         }
     }
 
index 25bf08b..17e3942 100644 (file)
@@ -128,6 +128,47 @@ close $filehandle;
 
 #-----------------------------------------------------------------------------
 
+## name autodie on via no parameters
+## failures 0
+## cut
+
+use autodie;
+close $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie on via :io
+## failures 0
+## cut
+
+use autodie qw< :io >;
+close $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie off
+## failures 1
+## cut
+
+use autodie qw< :system >;
+close $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie on and off
+## failures 1
+## TODO need to handle autodie lexically.
+## cut
+
+use autodie;
+{
+    no autodie;
+
+    close $filehandle;
+}
+
+#-----------------------------------------------------------------------------
+
 
 ##############################################################################
 #      $URL$
index 15b4f8a..c160db9 100644 (file)
@@ -130,6 +130,45 @@ open $filehandle, $filename;
 
 #-----------------------------------------------------------------------------
 
+## name autodie on via no parameters
+## failures 0
+## cut
+
+use autodie;
+open $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie on via :io
+## failures 0
+## cut
+
+use autodie qw< :io >;
+open $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie off
+## failures 1
+## cut
+
+use autodie qw< :system >;
+open $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie on and off
+## failures 1
+## TODO need to handle autodie lexically.
+## cut
+
+use autodie;
+{
+    no autodie;
+
+    open $filehandle;
+}
+
 
 ##############################################################################
 #      $URL$
index 3ef0936..22a3378 100644 (file)
@@ -260,6 +260,45 @@ close $filehandle;
 
 #-----------------------------------------------------------------------------
 
+## name autodie on via no parameters
+## failures 0
+## cut
+
+use autodie;
+close $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie on via :io
+## failures 0
+## cut
+
+use autodie qw< :io >;
+close $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie off
+## failures 1
+## cut
+
+use autodie qw< :system >;
+close $filehandle;
+
+#-----------------------------------------------------------------------------
+
+## name autodie on and off
+## failures 1
+## TODO need to handle autodie lexically.
+## cut
+
+use autodie;
+{
+    no autodie;
+
+    close $filehandle;
+}
+
 ## name config
 ## failures 0
 ## cut