From: Uri Guttman <uri@quad.(none)>
Date: Fri, 8 May 2009 06:00:10 +0000 (-0400)
Subject: created new test script to drive errors
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3f23e2e29932587767423f64c182dd9ccf33a18c;p=urisagit%2FPerl-Docs.git

created new test script to drive errors
---

diff --git a/t/error.t b/t/error.t
index 7333d09..d4845c0 100644
--- a/t/error.t
+++ b/t/error.t
@@ -1,65 +1,74 @@
 ##!/usr/local/bin/perl -w
 
-use strict ;
-
-use Test::More ;
-use Carp ;
-
-BEGIN{ 
-	use_ok( 'File::Slurp', ) ;
-}
-use File::Slurp ;
+use lib qw(t) ;
 
+use strict ;
+use File::Slurp qw( :all ) ;
 
-my $file = 'missing/file' ;
-unlink $file ;
+use common ;
 
-plan tests => 9 ;
+my $file_name = 'test_file' ;
+my $dir_name = 'test_dir' ;
 
-my %modes = (
-	'croak' => \&test_croak,
-	'carp' => \&test_carp,
-	'quiet' => \&test_quiet,
-) ;
+my $tests = [
 
-while( my( $mode, $sub ) = each %modes ) {
+	{
+		name	=> 'read_file open error',
+		sub	=> \&read_file,
+		args	=> [ $file_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 ) ;
-}
+		error => qr/open/,
+	},
 
+	{
+		name	=> 'write_file open error',
+		sub	=> \&write_file,
+		args	=> [ "$dir_name/$file_name", '' ],
+		pretest => sub {
+			mkdir $dir_name ;
+			chmod( 0555, $dir_name ) ;
+		},
 
-sub test_croak {
+		posttest => sub {
 
-	my ( $name, $sub, @args ) = @_ ;
+			chmod( 0777, $dir_name ) ;
+			rmdir $dir_name ;
+		},
 
-	eval {
-		$sub->( @args ) ;
-	} ;
+		error => qr/open/,
+	},
 
-	ok( $@, "$name can croak" ) ;
-}
+	{
+		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 ) ;
+		},
 
-sub test_carp {
+		posttest => sub {
 
-	my ( $name, $sub, @args ) = @_ ;
+			chmod( 0777, $dir_name ) ;
+			unlink( "$dir_name/$file_name.$$" ) ;
+			rmdir $dir_name ;
+		},
 
-	local $SIG{__WARN__} = sub { ok( 1, "$name can carp" ) } ;
+		error => qr/rename/,
+	},
 
-	$sub->( @args ) ;
-}
+	{
+		name	=> 'read_dir open error',
+		sub	=> \&read_dir,
+		args	=> [ $dir_name ],
 
-sub test_quiet {
+		error => qr/open/,
+	},
 
-	my ( $name, $sub, @args ) = @_ ;
+] ;
 
-	local $SIG{__WARN__} = sub { ok( 0, "$name can be quiet" ) } ;
+tester( $tests ) ;
 
-	eval {
-		$sub->( @args ) ;
-	} ;
+exit ;
 
-	ok( !$@, "$name can be quiet" ) ;
-}