cleaner close on tests, take 2

Message-ID: <m33d1tvjuq.fsf@anima.de>

(except for the three DB_File patch fragments)

p4raw-id: //depot/perl@13940

14 files changed, 105 insertions, 85 deletions

diff --git a/t/cmd/while.t b/t/cmd/while.t
index ecc15eda53..226db471ef 100755
--- a/t/cmd/while.t
+++ b/t/cmd/while.t
@@ -8,7 +8,7 @@ print tmp "tvi920\n";
 print tmp "vt100\n";
 print tmp "Amiga\n";
 print tmp "paper\n";
-close tmp;
+close tmp or die "Could not close: $!";
 
 # test "last" command
 
diff --git a/t/comp/cpp.aux b/t/comp/cpp.aux
index 058903294e..9452bddbbe 100755
--- a/t/comp/cpp.aux
+++ b/t/comp/cpp.aux
@@ -25,11 +25,11 @@ X#endif
 Xprint $ok;
 END
 print TRY $prog;
-close TRY;
+close TRY or die "Could not close Comp_cpp.tmp: $!";
 
 open(TRY,">Comp_cpp.inc") || (die "Can't open temp include file: $!");
 print TRY '#define OK "ok 3\n"' . "\n";
-close TRY;
+close TRY or die "Could not close Comp_cpp.tmp: $!";
 
 print `$^X "-P" Comp_cpp.tmp`;
 unlink "Comp_cpp.tmp", "Comp_cpp.inc";
diff --git a/t/comp/multiline.t b/t/comp/multiline.t
index 742ba4965d..78820c4e92 100755
--- a/t/comp/multiline.t
+++ b/t/comp/multiline.t
@@ -26,7 +26,7 @@ $y = 'now is the time' . "\n" .
 is($x, $y,  'test data is sane');
 
 print TRY $x;
-close TRY;
+close TRY or die "Could not close: $!";
 
 open(TRY,'Comp.try') || (die "Can't reopen temp file.");
 $count = 0;
diff --git a/t/comp/require.t b/t/comp/require.t
index 103a579235..ea4b96d20b 100755
--- a/t/comp/require.t
+++ b/t/comp/require.t
@@ -27,7 +27,7 @@ sub write_file {
     binmode REQ;
     use bytes;
     print REQ @_;
-    close REQ;
+    close REQ or die "Could not close $f: $!";
 }
 
 eval {require 5.005};
diff --git a/t/comp/script.t b/t/comp/script.t
index d70b767478..2dbdaf2afc 100755
--- a/t/comp/script.t
+++ b/t/comp/script.t
@@ -16,7 +16,7 @@ if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";}
 
 open(try,">Comp.script") || (die "Can't open temp file.");
 print try 'print "ok\n";'; print try "\n";
-close try;
+close try or die "Could not close: $!";
 
 $x = `$Perl Comp.script`;
 
diff --git a/t/io/argv.t b/t/io/argv.t
index 56b5714488..a602a02259 100755
--- a/t/io/argv.t
+++ b/t/io/argv.t
@@ -15,7 +15,7 @@ my $devnull = File::Spec->devnull;
 
 open(TRY, '>Io_argv1.tmp') || (die "Can't open temp file: $!");
 print TRY "a line\n";
-close TRY;
+close TRY or die "Could not close: $!";
 
 $x = runperl(
     prog	=> 'while (<>) { print $., $_; }',
@@ -50,9 +50,9 @@ is($y, "1a line\n2a line\n3a line\n", '<> from @ARGV');
 
 
 open(TRY, '>Io_argv1.tmp') or die "Can't open temp file: $!";
-close TRY;
+close TRY or die "Could not close: $!";
 open(TRY, '>Io_argv2.tmp') or die "Can't open temp file: $!";
-close TRY;
+close TRY or die "Could not close: $!";
 @ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp');
 $^I = '_bak';   # not .bak which confuses VMS
 $/ = undef;
@@ -67,7 +67,7 @@ open(TRY, '<Io_argv1.tmp') or die "Can't open temp file: $!";
 print while <TRY>;
 open(TRY, '<Io_argv2.tmp') or die "Can't open temp file: $!";
 print while <TRY>;
-close TRY;
+close TRY or die "Could not close: $!";
 undef $^I;
 
 ok( eof TRY );
@@ -95,7 +95,7 @@ ok( eof(),      'eof() true after closing ARGV' );
 
 {
     local $/;
-    open F, 'Io_argv1.tmp' or die;
+    open F, 'Io_argv1.tmp' or die "Could not open Io_argv1.tmp: $!";
     <F>;	# set $. = 1
     is( <F>, undef );
 
@@ -108,7 +108,7 @@ ok( eof(),      'eof() true after closing ARGV' );
     open F, $devnull or die;	# restart cycle again
     ok( defined(<F>) );
     is( <F>, undef );
-    close F;
+    close F or die "Could not close: $!";
 }
 
 END { unlink 'Io_argv1.tmp', 'Io_argv1.tmp_bak', 'Io_argv2.tmp', 'Io_argv2.tmp_bak' }
diff --git a/t/io/dup.t b/t/io/dup.t
index 96fe3bedeb..6555d07274 100755
--- a/t/io/dup.t
+++ b/t/io/dup.t
@@ -40,11 +40,11 @@ else {
     system sprintf "$echo 1>&2", 7;
 }
 
-close(STDOUT);
-close(STDERR);
+close(STDOUT) or die "Could not close: $!";
+close(STDERR) or die "Could not close: $!";
 
-open(STDOUT,">&DUPOUT");
-open(STDERR,">&DUPERR");
+open(STDOUT,">&DUPOUT") or die "Could not open: $!";
+open(STDERR,">&DUPERR") or die "Could not open: $!";
 
 if (($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'VMS')) { print `type Io.dup` }
 else                  { system 'cat Io.dup' }
diff --git a/t/lib/filter-util.pl b/t/lib/filter-util.pl
index 826d85307e..c378f221d7 100644
--- a/t/lib/filter-util.pl
+++ b/t/lib/filter-util.pl
@@ -25,7 +25,7 @@ sub writeFile
     binmode(F) if $filename =~ /bin$/i;
     foreach (@strings)
       { print F }
-    close F ;
+    close F or die "Could not close: $!" ;
 }
 
 sub ok
diff --git a/t/op/anonsub.t b/t/op/anonsub.t
index fef40f935a..8eca75b811 100755
--- a/t/op/anonsub.t
+++ b/t/op/anonsub.t
@@ -26,7 +26,7 @@ for (@prgs){
     my($prog,$expected) = split(/\nEXPECT\n/, $_);
     open TEST, ">$tmpfile";
     print TEST "$prog\n";
-    close TEST;
+    close TEST or die "Could not close: $!";
     my $results = $Is_VMS ?
 		`MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
 		  $Is_MSWin32 ?
diff --git a/t/op/do.t b/t/op/do.t
index 913481feb1..744a62b3c3 100755
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -61,31 +61,31 @@ unshift @INC, '.';
 
 if (open(DO, ">$$.16")) {
     print DO "ok(1, 'do in scalar context') if defined wantarray && not wantarray\n";
-    close DO;
+    close DO or die "Could not close: $!";
 }
 
 my $a = do "$$.16";
 
 if (open(DO, ">$$.17")) {
     print DO "ok(1, 'do in list context') if defined wantarray &&     wantarray\n";
-    close DO;
+    close DO or die "Could not close: $!";
 }
 
 my @a = do "$$.17";
 
 if (open(DO, ">$$.18")) {
     print DO "ok(1, 'do in void context') if not defined wantarray\n";
-    close DO;
+    close DO or die "Could not close: $!";
 }
 
 do "$$.18";
 
 # bug ID 20010920.007
 eval qq{ do qq(a file that does not exist); };
-ok( !$@ );
+ok( !$@, "do on a non-existing file, first try" );
 
 eval qq{ do uc qq(a file that does not exist); };
-ok( !$@ );
+ok( !$@, "do on a non-existing file, second try"  );
 
 END {
     1 while unlink("$$.16", "$$.17", "$$.18");
diff --git a/t/op/inccode.t b/t/op/inccode.t
index bd66628c0a..49ab85fbc0 100644
--- a/t/op/inccode.t
+++ b/t/op/inccode.t
@@ -20,7 +20,7 @@ sub get_temp_fh {
     push @tempfiles, $f;
     open my $fh, ">$f" or die "Can't create $f: $!";
     print $fh "package ".substr($_[0],0,-3)."; 1;";
-    close $fh;
+    close $fh or die "Couldn't close: $!";
     open $fh, $f or die "Can't open $f: $!";
     return $fh;
 }
@@ -39,22 +39,29 @@ sub fooinc {
 
 push @INC, \&fooinc;
 
-ok( !eval { require Bar; 1 },      'Trying non-magic package' );
-
-ok( eval { require Foo; 1 },       'require() magic via code ref'  ); 
-ok( exists $INC{'Foo.pm'},         '  %INC sees it' );
-is( ref $INC{'Foo.pm'}, 'CODE',    '  key is a coderef in %INC' );
-is( $INC{'Foo.pm'}, \&fooinc,	   '  key is correct in %INC' );
-
-ok( eval "use Foo1; 1;",           'use()' );  
-ok( exists $INC{'Foo1.pm'},        '  %INC sees it' );
-is( ref $INC{'Foo1.pm'}, 'CODE',   '  key is a coderef in %INC' );
-is( $INC{'Foo1.pm'}, \&fooinc,     '  key is correct in %INC' );
-
-ok( eval { do 'Foo2.pl'; 1 },      'do()' ); 
-ok( exists $INC{'Foo2.pl'},        '  %INC sees it' );
-is( ref $INC{'Foo2.pl'}, 'CODE',   '  key is a coderef in %INC' );
-is( $INC{'Foo2.pl'}, \&fooinc,     '  key is correct in %INC' );
+my $evalret = eval { require Bar; 1 };
+ok( !$evalret,      'Trying non-magic package' );
+
+$evalret = eval { require Foo; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Foo; magic via code ref'  );
+ok( exists $INC{'Foo.pm'},         '  %INC sees Foo.pm' );
+is( ref $INC{'Foo.pm'}, 'CODE',    '  val Foo.pm is a coderef in %INC' );
+is( $INC{'Foo.pm'}, \&fooinc,	   '  val Foo.pm is correct in %INC' );
+
+$evalret = eval "use Foo1; 1;";
+die $@ if $@;
+ok( $evalret,                      'use Foo1' );
+ok( exists $INC{'Foo1.pm'},        '  %INC sees Foo1.pm' );
+is( ref $INC{'Foo1.pm'}, 'CODE',   '  val Foo1.pm is a coderef in %INC' );
+is( $INC{'Foo1.pm'}, \&fooinc,     '  val Foo1.pm is correct in %INC' );
+
+$evalret = eval { do 'Foo2.pl'; 1 };
+die $@ if $@;
+ok( $evalret,                      'do "Foo2.pl"' );
+ok( exists $INC{'Foo2.pl'},        '  %INC sees Foo2.pl' );
+is( ref $INC{'Foo2.pl'}, 'CODE',   '  val Foo2.pl is a coderef in %INC' );
+is( $INC{'Foo2.pl'}, \&fooinc,     '  val Foo2.pl is correct in %INC' );
 
 pop @INC;
 
@@ -72,23 +79,28 @@ sub fooinc2 {
 my $arrayref = [ \&fooinc2, 'Bar' ];
 push @INC, $arrayref;
 
-ok( eval { require Foo; 1; },     'Originally loaded packages preserved' );
-ok( !eval { require Foo3; 1; },   'Original magic INC purged' );
-
-ok( eval { require Bar; 1 },      'require() magic via array ref' );
-ok( exists $INC{'Bar.pm'},        '  %INC sees it' );
-is( ref $INC{'Bar.pm'}, 'ARRAY',  '  key is an arrayref in %INC' );
-is( $INC{'Bar.pm'}, $arrayref,    '  key is correct in %INC' );
-
-ok( eval "use Bar1; 1;",          'use()' );
-ok( exists $INC{'Bar1.pm'},       '  %INC sees it' );
-is( ref $INC{'Bar1.pm'}, 'ARRAY', '  key is an arrayref in %INC' );
-is( $INC{'Bar1.pm'}, $arrayref,   '  key is correct in %INC' );
-
-ok( eval { do 'Bar2.pl'; 1 },     'do()' );
-ok( exists $INC{'Bar2.pl'},       '  %INC sees it' );
-is( ref $INC{'Bar2.pl'}, 'ARRAY', '  key is an arrayref in %INC' );
-is( $INC{'Bar2.pl'}, $arrayref,   '  key is correct in %INC' );
+$evalret = eval { require Foo; 1; };
+die $@ if $@;
+ok( $evalret,                     'Originally loaded packages preserved' );
+$evalret = eval { require Foo3; 1; };
+ok( !$evalret,                    'Original magic INC purged' );
+
+$evalret = eval { require Bar; 1 };
+die $@ if $@;
+ok( $evalret,                     'require Bar; magic via array ref' );
+ok( exists $INC{'Bar.pm'},        '  %INC sees Bar.pm' );
+is( ref $INC{'Bar.pm'}, 'ARRAY',  '  val Bar.pm is an arrayref in %INC' );
+is( $INC{'Bar.pm'}, $arrayref,    '  val Bar.pm is correct in %INC' );
+
+ok( eval "use Bar1; 1;",          'use Bar1' );
+ok( exists $INC{'Bar1.pm'},       '  %INC sees Bar1.pm' );
+is( ref $INC{'Bar1.pm'}, 'ARRAY', '  val Bar1.pm is an arrayref in %INC' );
+is( $INC{'Bar1.pm'}, $arrayref,   '  val Bar1.pm is correct in %INC' );
+
+ok( eval { do 'Bar2.pl'; 1 },     'do "Bar2.pl"' );
+ok( exists $INC{'Bar2.pl'},       '  %INC sees Bar2.pl' );
+is( ref $INC{'Bar2.pl'}, 'ARRAY', '  val Bar2.pl is an arrayref in %INC' );
+is( $INC{'Bar2.pl'}, $arrayref,   '  val Bar2.pl is correct in %INC' );
 
 pop @INC;
 
@@ -105,33 +117,39 @@ sub FooLoader::INC {
 my $href = bless( {}, 'FooLoader' );
 push @INC, $href;
 
-ok( eval { require Quux; 1 },      'require() magic via hash object' );
-ok( exists $INC{'Quux.pm'},        '  %INC sees it' );
+$evalret = eval { require Quux; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Quux; magic via hash object' );
+ok( exists $INC{'Quux.pm'},        '  %INC sees Quux.pm' );
 is( ref $INC{'Quux.pm'}, 'FooLoader',
-				   '  key is an object in %INC' );
-is( $INC{'Quux.pm'}, $href,        '  key is correct in %INC' );
+				   '  val Quux.pm is an object in %INC' );
+is( $INC{'Quux.pm'}, $href,        '  val Quux.pm is correct in %INC' );
 
 pop @INC;
 
 my $aref = bless( [], 'FooLoader' );
 push @INC, $aref;
 
-ok( eval { require Quux1; 1 },     'require() magic via array object' );
-ok( exists $INC{'Quux1.pm'},       '  %INC sees it' );
+$evalret = eval { require Quux1; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Quux1; magic via array object' );
+ok( exists $INC{'Quux1.pm'},       '  %INC sees Quux1.pm' );
 is( ref $INC{'Quux1.pm'}, 'FooLoader',
-				   '  key is an object in %INC' );
-is( $INC{'Quux1.pm'}, $aref,       '  key is correct in %INC' );
+				   '  val Quux1.pm is an object in %INC' );
+is( $INC{'Quux1.pm'}, $aref,       '  val Quux1.pm  is correct in %INC' );
 
 pop @INC;
 
 my $sref = bless( \(my $x = 1), 'FooLoader' );
 push @INC, $sref;
 
-ok( eval { require Quux2; 1 },     'require() magic via scalar object' );
-ok( exists $INC{'Quux2.pm'},       '  %INC sees it' );
+$evalret = eval { require Quux2; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Quux2; magic via scalar object' );
+ok( exists $INC{'Quux2.pm'},       '  %INC sees Quux2.pm' );
 is( ref $INC{'Quux2.pm'}, 'FooLoader',
-				   '  key is an object in %INC' );
-is( $INC{'Quux2.pm'}, $sref,       '  key is correct in %INC' );
+				   '  val Quux2.pm is an object in %INC' );
+is( $INC{'Quux2.pm'}, $sref,       '  val Quux2.pm is correct in %INC' );
 
 pop @INC;
 
@@ -146,9 +164,11 @@ push @INC, sub {
     }
 };
 
-ok( eval { require Toto; 1 },      'require() magic via anonymous code ref'  );
-ok( exists $INC{'Toto.pm'},        '  %INC sees it' );
-ok( ! ref $INC{'Toto.pm'},         q/  key isn't a ref in %INC/ );
-is( $INC{'Toto.pm'}, 'xyz',	   '  key is correct in %INC' );
+$evalret = eval { require Toto; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Toto; magic via anonymous code ref'  );
+ok( exists $INC{'Toto.pm'},        '  %INC sees Toto.pm' );
+ok( ! ref $INC{'Toto.pm'},         q/  val Toto.pm isn't a ref in %INC/ );
+is( $INC{'Toto.pm'}, 'xyz',	   '  val Toto.pm is correct in %INC' );
 
 pop @INC;
diff --git a/t/op/runlevel.t b/t/op/runlevel.t
index 03e253e6e6..6a10e8b4ab 100755
--- a/t/op/runlevel.t
+++ b/t/op/runlevel.t
@@ -31,7 +31,7 @@ for (@prgs){
     my($prog,$expected) = split(/\nEXPECT\n/, $_);
     open TEST, ">$tmpfile";
     print TEST "$prog\n";
-    close TEST;
+    close TEST or die "Could not close: $!";
     my $results = $Is_VMS ?
                       `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
 		  $Is_MSWin32 ?  
diff --git a/t/op/write.t b/t/op/write.t
index fdc6e56d86..24759965a4 100755
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -36,7 +36,7 @@ $good = 'good';
 $multiline = "forescore\nand\nseven years\n";
 $foo = 'when in the course of human events it becomes necessary';
 write(OUT);
-close OUT;
+close OUT or die "Could not close: $!";
 
 $right =
 "the quick brown fox
@@ -75,7 +75,7 @@ $good = 'good';
 $multiline = "forescore\nand\nseven years\n";
 $foo = 'when in the course of human events it becomes necessary';
 write(OUT2);
-close OUT2;
+close OUT2 or die "Could not close: $!";
 
 $right =
 "the quick brown fox
@@ -118,7 +118,7 @@ $good = 'good';
 $multiline = "forescore\nand\nseven years\n";
 $foo = 'when in the course of human events it becomes necessary';
 write(OUT2);
-close OUT2;
+close OUT2 or die "Could not close: $!";
 
 $right =
 "the brown quick fox
@@ -185,7 +185,7 @@ open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 
 $foo = 'fit          ';
 write(OUT3);
-close OUT3;
+close OUT3 or die "Could not close: $!";
 
 $right =
 "fit\n";
@@ -207,7 +207,7 @@ $this,$that
     write LEX;
     $that = 8;
     write LEX;
-    close LEX;
+    close LEX or die "Could not close: $!";
 }
 # LEX_INTERPNORMAL test
 my %e = ( a => 1 );
@@ -217,7 +217,7 @@ format OUT4 =
 .
 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
 write (OUT4);
-close  OUT4;
+close  OUT4 or die "Could not close: $!";
 if (`$CAT Op_write.tmp` eq "1\n") {
     print "ok 9\n";
     1 while unlink "Op_write.tmp";
@@ -237,7 +237,7 @@ open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 
 $test1 = 12.95;
 write(OUT10);
-close OUT10;
+close OUT10 or die "Could not close: $!";
 
 $right = "   12.95 00012.95\n";
 if (`$CAT Op_write.tmp` eq $right)
@@ -260,7 +260,7 @@ open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 
 $test1 = 12.95;
 write(OUT11);
-close OUT11;
+close OUT11 or die "Could not close: $!";
 
 $right = 
 "00012.95
diff --git a/t/run/switches.t b/t/run/switches.t
index 67331b63cd..f920f37ca7 100644
--- a/t/run/switches.t
+++ b/t/run/switches.t
@@ -77,7 +77,7 @@ INIT  { print "block 3\n"; }
 	print "block 4\n";
 END   { print "block 5\n"; }
 SWTEST
-    close $f;
+    close $f or die "Could not close: $!";
     $r = runperl(
 	switches	=> [ '-c' ],
 	progfile	=> $filename,
@@ -122,7 +122,7 @@ SKIP: {
 #!perl -s
 print $x
 SWTEST
-    close $f;
+    close $f or die "Could not close: $!";
     $r = runperl(
 	switches    => [ '-s' ],
 	progfile    => $filename,
@@ -142,7 +142,7 @@ package swtest;
 sub import { print map "<$_>", @_ }
 1;
 SWTESTPM
-    close $f;
+    close $f or die "Could not close: $!";
     $r = runperl(
 	switches    => [ '-Mswtest' ],
 	prog	    => '1',