deleted

[urisagit/Perl-Docs.git] / t / error.t

diff --git a/t/error.t b/t/error.t
index 7333d09..ff5a6d7 100644 (file)
--- a/t/error.t
+++ b/t/error.t
@@ -1,65 +1,128 @@
 ##!/usr/local/bin/perl -w
 
+use lib qw(t) ;
 use strict ;
+use driver ;
 
-use Test::More ;
-use Carp ;
+use File::Slurp qw( :all ) ;
 
-BEGIN{ 
-       use_ok( 'File::Slurp', ) ;
-}
-use File::Slurp ;
+my $file_name = 'test_file' ;
+my $dir_name = 'test_dir' ;
 
+my $tests = [
 
-my $file = 'missing/file' ;
-unlink $file ;
+       {
+               name    => 'read_file open error',
+               sub     => \&read_file,
+               args    => [ $file_name ],
 
-plan tests => 9 ;
+               error => qr/open/,
 
-my %modes = (
-       'croak' => \&test_croak,
-       'carp' => \&test_carp,
-       'quiet' => \&test_quiet,
-) ;
+               skip    => 1,
+       },
 
-while( my( $mode, $sub ) = each %modes ) {
+       {
+               name    => 'write_file open error',
+               sub     => \&write_file,
+               args    => [ "$dir_name/$file_name", '' ],
+               pretest => sub {
+                       mkdir $dir_name ;
+                       chmod( 0555, $dir_name ) ;
+               },
 
-       $sub->( 'read_file', \&read_file, $file, err_mode => $mode ) ;
-       $sub->( 'write_file', \&write_file, $file,
-                                       { err_mode => $mode }, 'junk' ) ;
-       $sub->( 'read_dir', \&read_dir, $file, err_mode => $mode ) ;
-}
+               posttest => sub {
 
+                       chmod( 0777, $dir_name ) ;
+                       rmdir $dir_name ;
+               },
 
-sub test_croak {
+               error => qr/open/,
+               skip    => 1,
+       },
 
-       my ( $name, $sub, @args ) = @_ ;
+       {
+               name    => 'write_file syswrite error',
+               sub     => \&write_file,
+               args    => [ $file_name, '' ],
+               override        => 'syswrite',
 
-       eval {
-               $sub->( @args ) ;
-       } ;
+               posttest => sub {
+                       unlink( $file_name ) ;
+               },
 
-       ok( $@, "$name can croak" ) ;
-}
 
-sub test_carp {
+               error => qr/write/,
+               skip    => 1,
+       },
 
-       my ( $name, $sub, @args ) = @_ ;
+       {
+               name    => 'read_file small sysread error',
+               sub     => \&read_file,
+               args    => [ $file_name ],
+               override        => 'sysread',
 
-       local $SIG{__WARN__} = sub { ok( 1, "$name can carp" ) } ;
+               pretest => sub {
+                       write_file( $file_name, '' ) ;
+               },
 
-       $sub->( @args ) ;
-}
+               posttest => sub {
+                       unlink( $file_name ) ;
+               },
 
-sub test_quiet {
 
-       my ( $name, $sub, @args ) = @_ ;
+               error => qr/read/,
+       },
 
-       local $SIG{__WARN__} = sub { ok( 0, "$name can be quiet" ) } ;
+       {
+               name    => 'read_file loop sysread error',
+               sub     => \&read_file,
+               args    => [ $file_name ],
+               override        => 'sysread',
 
-       eval {
-               $sub->( @args ) ;
-       } ;
+               pretest => sub {
+                       write_file( $file_name, 'x' x 100_000 ) ;
+               },
+
+               posttest => sub {
+                       unlink( $file_name ) ;
+               },
+
+
+               error => qr/read/,
+       },
+
+       {
+               name    => 'atomic rename error',
+               sub     => \&write_file,
+               args    => [ "$dir_name/$file_name", { atomic => 1 }, '' ],
+               pretest => sub {
+                       mkdir $dir_name ;
+                       write_file( "$dir_name/$file_name.$$", '' ) ;
+                       chmod( 0555, $dir_name ) ;
+               },
+
+               posttest => sub {
+
+                       chmod( 0777, $dir_name ) ;
+                       unlink( "$dir_name/$file_name.$$" ) ;
+                       rmdir $dir_name ;
+               },
+
+               error => qr/rename/,
+               skip    => 1,
+       },
+
+       {
+               name    => 'read_dir opendir error',
+               sub     => \&read_dir,
+               args    => [ $dir_name ],
+
+               error => qr/open/,
+               skip    => 1,
+       },
+] ;
+
+test_driver( $tests ) ;
+
+exit ;
 
-       ok( !$@, "$name can be quiet" ) ;
-}