cleaner close on tests, take 2
Andreas König [Sat, 29 Dec 2001 21:42:37 +0000 (22:42 +0100)]
Message-ID: <m33d1tvjuq.fsf@anima.de>

(except for the three DB_File patch fragments)

p4raw-id: //depot/perl@13940

19 files changed:
ext/Devel/DProf/DProf.t
ext/PerlIO/t/encoding.t
ext/SDBM_File/sdbm.t
ext/Storable/t/store.t
lib/strict.t
t/cmd/while.t
t/comp/cpp.aux
t/comp/multiline.t
t/comp/require.t
t/comp/script.t
t/io/argv.t
t/io/dup.t
t/lib/filter-util.pl
t/op/anonsub.t
t/op/do.t
t/op/inccode.t
t/op/runlevel.t
t/op/write.t
t/run/switches.t

index be711f1..5ecba68 100644 (file)
@@ -49,7 +49,7 @@ sub profile {
        my $t_start = new Benchmark;
         open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n";
        @results = <R>;
-       close R;
+       close R or warn "Could not close: $!";
        my $t_total = timediff( new Benchmark, $t_start );
 
        if( $opt_v ){
index e30e270..eb523ca 100644 (file)
@@ -19,7 +19,7 @@ my $russki = "koi8r$$";
 if (open(GRK, ">$grk")) {
     # alpha beta gamma in ISO 8859-7
     print GRK "\xe1\xe2\xe3";
-    close GRK;
+    close GRK or die "Could not close: $!";
 }
 
 {
@@ -30,7 +30,7 @@ if (open(GRK, ">$grk")) {
     print "ok 2\n";
     print $o readline($i);
     print "ok 3\n";
-    close($o);
+    close($o) or die "Could not close: $!";
     close($i);
 }
 
@@ -49,7 +49,7 @@ if (open(UTF, "<$utf")) {
     print "ok 6\n";
     print $o readline($i);
     print "ok 7\n";
-    close($o);
+    close($o) or die "Could not close: $!";
     close($i);
 }
 
@@ -76,7 +76,7 @@ if (!defined $warn) {
 
 if (open(RUSSKI, ">$russki")) {
     print RUSSKI "\x3c\x3f\x78";
-    close RUSSKI;
+    close RUSSKI or die "Could not close: $!";
     open(RUSSKI, "$russki");
     binmode(RUSSKI, ":raw");
     my $buf1;
index e1ed259..f1a5c63 100644 (file)
@@ -183,7 +183,7 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
    1 ;
 EOM
 
-    close FILE ;
+    close FILE  or die "Could not close: $!";
 
     BEGIN { push @INC, '.'; }
 
index d26755f..b09b125 100644 (file)
@@ -113,7 +113,7 @@ eval { $r = fd_retrieve(::OUT); };
 print "not " unless $@;
 print "ok 20\n";
 
-close OUT;
+close OUT or die "Could not close: $!";
 END { 1 while unlink 'store' }
 
 
index 3a0a2ec..f03271b 100644 (file)
@@ -31,7 +31,7 @@ foreach (sort glob($^O eq 'MacOS' ? ":lib::strict:*" : "lib/strict/*")) {
         local $/ = undef;
         @prgs = (@prgs, split "\n########\n", <F>) ;
     }
-    close F ;
+    close F or die "Could not close: $!" ;
 }
 
 undef $/;
@@ -59,7 +59,7 @@ for (@prgs){
            push @temps, $filename ;
            open F, ">$filename" or die "Cannot open $filename: $!\n" ;
            print F $code ;
-           close F ;
+           close F or die "Could not close: $!" ;
        }
        shift @files ;
        $prog = shift @files ;
@@ -67,7 +67,7 @@ for (@prgs){
     }
     open TEST, ">$tmpfile";
     print TEST $prog,"\n";
-    close TEST;
+    close TEST or die "Could not close: $!";
     my $results = $Is_MSWin32 ?
                      `.\\perl -I../lib $switch $tmpfile 2>&1` :
                   $^O eq 'NetWare' ?
index ecc15ed..226db47 100755 (executable)
@@ -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
 
index 0589032..9452bdd 100755 (executable)
@@ -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";
index 742ba49..78820c4 100755 (executable)
@@ -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;
index 103a579..ea4b96d 100755 (executable)
@@ -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};
index d70b767..2dbdaf2 100755 (executable)
@@ -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`;
 
index 56b5714..a602a02 100755 (executable)
@@ -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' }
index 96fe3be..6555d07 100755 (executable)
@@ -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' }
index 826d853..c378f22 100644 (file)
@@ -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
index fef40f9..8eca75b 100755 (executable)
@@ -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 ?
index 913481f..744a62b 100755 (executable)
--- 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");
index bd66628..49ab85f 100644 (file)
@@ -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;
index 03e253e..6a10e8b 100755 (executable)
@@ -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 ?  
index fdc6e56..2475996 100755 (executable)
@@ -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
index 67331b6..f920f37 100644 (file)
@@ -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',