From: Nicholas Clark Date: Thu, 7 Aug 2008 15:21:57 +0000 (+0000) Subject: Convert all unimaginative (ie race condition) temporary file names to X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=62a28c976c312a2c7269acc71060b1037a453bea;p=p5sagit%2Fp5-mst-13.2.git Convert all unimaginative (ie race condition) temporary file names to use test.pl's tempfile(). p4raw-id: //depot/perl@34182 --- diff --git a/t/io/crlf.t b/t/io/crlf.t index c3c23e0..4c97a91 100644 --- a/t/io/crlf.t +++ b/t/io/crlf.t @@ -9,10 +9,7 @@ use Config; require "test.pl"; -my $file = "crlf$$.dat"; -END { - 1 while unlink($file); -} +my $file = tempfile(); if (find PerlIO::Layer 'perlio') { plan(tests => 16); diff --git a/t/io/dup.t b/t/io/dup.t index 3f211b4..18277d9 100755 --- a/t/io/dup.t +++ b/t/io/dup.t @@ -17,7 +17,9 @@ print "ok 1\n"; open(DUPOUT,">&STDOUT"); open(DUPERR,">&STDERR"); -open(STDOUT,">Io.dup") || die "Can't open stdout"; +my $tempfile = tempfile(); + +open(STDOUT,">$tempfile") || die "Can't open stdout"; open(STDERR,">&STDOUT") || die "Can't open stderr"; select(STDERR); $| = 1; @@ -57,10 +59,9 @@ close(STDERR) or die "Could not close: $!"; 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` } -elsif ($^O eq 'MacOS') { system 'catenate Io.dup' } -else { system 'cat Io.dup' } -unlink 'Io.dup'; +if (($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'VMS')) { print `type $tempfile` } +elsif ($^O eq 'MacOS') { system "catenate $tempfile" } +else { system "cat $tempfile" } print STDOUT "ok 8\n"; @@ -110,7 +111,7 @@ SKIP: { is(fileno(F), fileno(STDERR)); close F; - open(G, ">dup$$") or die; + open(G, ">$tempfile") or die; my $g = fileno(G); ok(open(F, ">&=$g")); @@ -126,7 +127,7 @@ SKIP: { close G; # flush first close F; # flush second - open(G, "; chomp $line; is($line, "ggg"); @@ -134,7 +135,7 @@ SKIP: { } close G; - open UTFOUT, '>:utf8', "dup$$" or die $!; + open UTFOUT, '>:utf8', $tempfile or die $!; open UTFDUP, '>&UTFOUT' or die $!; # some old greek saying. my $message = "\x{03A0}\x{0391}\x{039D}\x{03A4}\x{0391} \x{03A1}\x{0395}\x{0399}\n"; @@ -144,7 +145,7 @@ SKIP: { print UTFDUP $message; close UTFOUT; close UTFDUP; - open(UTFIN, "<:utf8", "dup$$") or die $!; + open(UTFIN, "<:utf8", $tempfile) or die $!; { my $line; $line = ; is($line, $message); @@ -153,5 +154,4 @@ SKIP: { } close UTFIN; - END { 1 while unlink "dup$$" } } diff --git a/t/io/fflush.t b/t/io/fflush.t index 19143c6..056517fd 100644 --- a/t/io/fflush.t +++ b/t/io/fflush.t @@ -37,14 +37,6 @@ if ($useperlio || $fflushNULL || $d_sfio) { my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; $runperl .= qq{ "-I../lib"}; -my @delete; - -END { - for (@delete) { - unlink $_ or warn "unlink $_: $!"; - } -} - sub file_eq { my $f = shift; my $val = shift; @@ -60,7 +52,8 @@ sub file_eq { # This script will be used as the command to execute from # child processes -open PROG, "> ff-prog" or die "open ff-prog: $!"; +my $ffprog = tempfile(); +open PROG, "> $ffprog" or die "open $ffprog: $!"; print PROG <<'EOF'; my $f = shift; my $str = shift; @@ -69,8 +62,7 @@ print OUT $str; close OUT; EOF ; -close PROG or die "close ff-prog: $!";; -push @delete, "ff-prog"; +close PROG or die "close $ffprog: $!";; $| = 0; # we want buffered output @@ -78,7 +70,7 @@ $| = 0; # we want buffered output if (!$d_fork) { print "ok 1 # skipped: no fork\n"; } else { - my $f = "ff-fork-$$"; + my $f = tempfile(); open OUT, "> $f" or die "open $f: $!"; print OUT "Pe"; my $pid = fork; @@ -89,7 +81,7 @@ if (!$d_fork) { } elsif (defined $pid) { # Kid print OUT "r"; - my $command = qq{$runperl "ff-prog" "$f" "l"}; + my $command = qq{$runperl "$ffprog" "$f" "l"}; print "# $command\n"; exec $command or die $!; exit; @@ -99,7 +91,6 @@ if (!$d_fork) { } print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n"; - push @delete, $f; } # Test flush on system/qx/pipe open @@ -121,15 +112,14 @@ my %subs = ( my $t = 2; for (qw(system qx popen)) { my $code = $subs{$_}; - my $f = "ff-$_-$$"; - my $command = qq{$runperl "ff-prog" "$f" "rl"}; + my $f = tempfile(); + my $command = qq{$runperl $ffprog "$f" "rl"}; open OUT, "> $f" or die "open $f: $!"; print OUT "Pe"; close OUT or die "close $f: $!";; print "# $command\n"; $code->($command); print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n"; - push @delete, $f; ++$t; } diff --git a/t/io/fs.t b/t/io/fs.t index 5113a5f..095239b 100755 --- a/t/io/fs.t +++ b/t/io/fs.t @@ -51,25 +51,27 @@ my $skip_mode_checks = plan tests => 51; +my $tmpdir = tempfile(); +my $tmpdir1 = tempfile(); if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { - `rmdir /s /q tmp 2>nul`; - `mkdir tmp`; + `rmdir /s /q $tmpdir 2>nul`; + `mkdir $tmpdir`; } elsif ($^O eq 'VMS') { - `if f\$search("[.tmp]*.*") .nes. "" then delete/nolog/noconfirm [.tmp]*.*.*`; - `if f\$search("tmp.dir") .nes. "" then set file/prot=o:rwed tmp.dir;`; - `if f\$search("tmp.dir") .nes. "" then delete/nolog/noconfirm tmp.dir;`; - `create/directory [.tmp]`; + `if f\$search("[.$tmpdir]*.*") .nes. "" then delete/nolog/noconfirm [.$tmpdir]*.*.*`; + `if f\$search("$tmpdir.dir") .nes. "" then set file/prot=o:rwed $tmpdir.dir;`; + `if f\$search("$tmpdir.dir") .nes. "" then delete/nolog/noconfirm $tmpdir.dir;`; + `create/directory [.$tmpdir]`; } elsif ($Is_MacOS) { - rmdir "tmp"; mkdir "tmp"; + rmdir "$tmpdir"; mkdir "$tmpdir"; } else { - `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; + `rm -f $tmpdir 2>/dev/null; mkdir $tmpdir 2>/dev/null`; } -chdir catdir(curdir(), 'tmp'); +chdir catdir(curdir(), $tmpdir); `/bin/rm -rf a b c x` if -x '/bin/rm'; @@ -330,8 +332,8 @@ SKIP: { unlink("TEST$$"); } -unlink "Iofs.tmp"; -open IOFSCOM, ">Iofs.tmp" or die "Could not write IOfs.tmp: $!"; +my $tmpfile = tempfile(); +open IOFSCOM, ">$tmpfile" or die "Could not write IOfs.tmp: $!"; print IOFSCOM 'helloworld'; close(IOFSCOM); @@ -340,24 +342,24 @@ close(IOFSCOM); SKIP: { # Check truncating a closed file. - eval { truncate "Iofs.tmp", 5; }; + eval { truncate $tmpfile, 5; }; skip("no truncate - $@", 8) if $@; - is(-s "Iofs.tmp", 5, "truncation to five bytes"); + is(-s $tmpfile, 5, "truncation to five bytes"); - truncate "Iofs.tmp", 0; + truncate $tmpfile, 0; - ok(-z "Iofs.tmp", "truncation to zero bytes"); + ok(-z $tmpfile, "truncation to zero bytes"); #these steps are necessary to check if file is really truncated #On Win95, FH is updated, but file properties aren't - open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp"; + open(FH, ">$tmpfile") or die "Can't create $tmpfile"; print FH "x\n" x 200; close FH; # Check truncating an open file. - open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending"; + open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; binmode FH; select FH; @@ -371,7 +373,7 @@ SKIP: { } if ($needs_fh_reopen) { - close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; + close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; } SKIP: { @@ -379,19 +381,19 @@ SKIP: { skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5); } - is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)"); + is(-s $tmpfile, 200, "fh resize to 200 working (filename check)"); ok(truncate(FH, 0), "fh resize to zero"); if ($needs_fh_reopen) { - close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; + close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; } - ok(-z "Iofs.tmp", "fh resize to zero working (filename check)"); + ok(-z $tmpfile, "fh resize to zero working (filename check)"); close FH; - open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending"; + open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; binmode FH; select FH; @@ -405,10 +407,10 @@ SKIP: { } if ($needs_fh_reopen) { - close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; + close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; } - is(-s "Iofs.tmp", 100, "fh resize by IO slot working"); + is(-s $tmpfile, 100, "fh resize by IO slot working"); close FH; } @@ -419,7 +421,7 @@ SKIP: { skip "Works in Cygwin only if check_case is set to relaxed", 1 if ($ENV{'CYGWIN'} && ($ENV{'CYGWIN'} =~ /check_case:(?:adjust|strict)/)); - chdir './tmp'; + chdir "./$tmpdir"; open(FH,'>x') || die "Can't create x"; close(FH); rename('x', 'X'); @@ -434,15 +436,15 @@ SKIP: { # check if rename() works on directories if ($^O eq 'VMS') { # must have delete access to rename a directory - `set file tmp.dir/protection=o:d`; - ok(rename('tmp.dir', 'tmp1.dir'), "rename on directories") || + `set file $tmpdir.dir/protection=o:d`; + ok(rename('$tmpdir.dir', '$tmpdir1.dir'), "rename on directories") || print "# errno: $!\n"; } else { - ok(rename('tmp', 'tmp1'), "rename on directories"); + ok(rename($tmpdir, $tmpdir1), "rename on directories"); } -ok(-d 'tmp1', "rename on directories working"); +ok(-d $tmpdir1, "rename on directories working"); { # Change 26011: Re: A surprising segfault @@ -455,5 +457,5 @@ ok(-d 'tmp1', "rename on directories working"); ok(1, "extend sp in pp_chown"); } -# need to remove 'tmp' if rename() in test 28 failed! -END { rmdir 'tmp1'; rmdir 'tmp'; 1 while unlink "Iofs.tmp"; } +# need to remove $tmpdir if rename() in test 28 failed! +END { rmdir $tmpdir1; rmdir $tmpdir; } diff --git a/t/io/inplace.t b/t/io/inplace.t index a7a21e4..a9664dc 100755 --- a/t/io/inplace.t +++ b/t/io/inplace.t @@ -6,10 +6,10 @@ $^I = $^O eq 'VMS' ? '_bak' : '.bak'; plan( tests => 2 ); -my @tfiles = ('.a','.b','.c'); -my @tfiles_bak = (".a$^I", ".b$^I", ".c$^I"); +my @tfiles = (tempfile(), tempfile(), tempfile()); +my @tfiles_bak = map "$_$^I", @tfiles; -END { unlink_all('.a','.b','.c',".a$^I", ".b$^I", ".c$^I"); } +END { unlink_all(@tfiles_bak); } for my $file (@tfiles) { runperl( prog => 'print qq(foo\n);', diff --git a/t/io/iprefix.t b/t/io/iprefix.t index 25dd69d..9e09ce0 100755 --- a/t/io/iprefix.t +++ b/t/io/iprefix.t @@ -2,16 +2,16 @@ use strict; require './test.pl'; -$^I = 'bak*'; +$^I = 'bak.*'; # Modified from the original inplace.t to test adding prefixes plan( tests => 2 ); -my @tfiles = ('.a','.b','.c'); -my @tfiles_bak = ('bak.a', 'bak.b', 'bak.c'); +my @tfiles = (tempfile(), tempfile(), tempfile()); +my @tfiles_bak = map "bak.$_", @tfiles; -END { unlink_all('.a','.b','.c', 'bak.a', 'bak.b', 'bak.c'); } +END { unlink_all(@tfiles_bak); } for my $file (@tfiles) { runperl( prog => 'print qq(foo\n);', diff --git a/t/io/layers.t b/t/io/layers.t index abbc7ec..cddd436 100644 --- a/t/io/layers.t +++ b/t/io/layers.t @@ -125,7 +125,8 @@ SKIP: { $UTF8_STDIN ? [ "stdio", "utf8" ] : [ "stdio" ], "STDIN"); - open(F, ">:crlf", "afile"); + my $afile = tempfile(); + open(F, ">:crlf", $afile); check([ PerlIO::get_layers(F) ], [ qw(stdio crlf) ], @@ -199,8 +200,8 @@ SKIP: { { use open(IN => ":crlf", OUT => ":encoding(cp1252)"); - open F, "afile"; + open F, '<', $afile; + open G, '>', $afile; check([ PerlIO::get_layers(F, input => 1) ], [ qw(stdio crlf) ], @@ -216,10 +217,8 @@ SKIP: { # Check that PL_sigwarn's reference count is correct, and that # &PerlIO::Layer::NoWarnings isn't prematurely freed. - fresh_perl_like (<<'EOT', qr/^CODE/); -open(UTF, "<:raw:encoding(utf8)", "afile") or die $!; + fresh_perl_like (<<"EOT", qr/^CODE/); +open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!; print ref *PerlIO::Layer::NoWarnings{CODE}; EOT - - 1 while unlink "afile"; } diff --git a/t/io/nargv.t b/t/io/nargv.t index 97ab639..c5b84fc 100755 --- a/t/io/nargv.t +++ b/t/io/nargv.t @@ -1,5 +1,11 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require "./test.pl"; +} + print "1..5\n"; my $j = 1; @@ -56,9 +62,13 @@ sub other { } } +my @files; sub mkfiles { - my @files = map { "scratch$_" } @_; - return wantarray ? @files : $files[-1]; + foreach (@_) { + $files[$_] ||= tempfile(); + } + my @results = @files[@_]; + return wantarray ? @results : @results[-1]; } END { unlink map { ($_, "$_.bak") } mkfiles(1..5) } diff --git a/t/io/open.t b/t/io/open.t index 68b828a..325d637 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -15,14 +15,15 @@ plan tests => 108; my $Perl = which_perl(); +my $afile = tempfile(); { - unlink("afile") if -f "afile"; + unlink($afile) if -f $afile; - $! = 0; # the -f above will set $! if 'afile' doesn't exist. - ok( open(my $f,"+>afile"), 'open(my $f, "+>...")' ); + $! = 0; # the -f above will set $! if $afile doesn't exist. + ok( open(my $f,"+>$afile"), 'open(my $f, "+>...")' ); binmode $f; - ok( -f "afile", ' its a file'); + ok( -f $afile, ' its a file'); ok( (print $f "SomeData\n"), ' we can print to it'); is( tell($f), 9, ' tell()' ); ok( seek($f,0,0), ' seek set' ); @@ -35,25 +36,25 @@ my $Perl = which_perl(); like( $@, qr/<\$f> line 1/, ' die message correct' ); ok( close($f), ' close()' ); - ok( unlink("afile"), ' unlink()' ); + ok( unlink($afile), ' unlink()' ); } { - ok( open(my $f,'>', 'afile'), "open(my \$f, '>', 'afile')" ); + ok( open(my $f,'>', $afile), "open(my \$f, '>', $afile)" ); ok( (print $f "a row\n"), ' print'); ok( close($f), ' close' ); - ok( -s 'afile' < 10, ' -s' ); + ok( -s $afile < 10, ' -s' ); } { - ok( open(my $f,'>>', 'afile'), "open(my \$f, '>>', 'afile')" ); + ok( open(my $f,'>>', $afile), "open(my \$f, '>>', $afile)" ); ok( (print $f "a row\n"), ' print' ); ok( close($f), ' close' ); - ok( -s 'afile' > 10, ' -s' ); + ok( -s $afile > 10, ' -s' ); } { - ok( open(my $f, '<', 'afile'), "open(my \$f, '<', 'afile')" ); + ok( open(my $f, '<', $afile), "open(my \$f, '<', $afile)" ); my @rows = <$f>; is( scalar @rows, 2, ' readline, list context' ); is( $rows[0], "a row\n", ' first line read' ); @@ -62,17 +63,17 @@ my $Perl = which_perl(); } { - ok( -s 'afile' < 20, '-s' ); + ok( -s $afile < 20, '-s' ); - ok( open(my $f, '+<', 'afile'), 'open +<' ); + ok( open(my $f, '+<', $afile), 'open +<' ); my @rows = <$f>; is( scalar @rows, 2, ' readline, list context' ); ok( seek($f, 0, 1), ' seek cur' ); ok( (print $f "yet another row\n"), ' print' ); ok( close($f), ' close' ); - ok( -s 'afile' > 20, ' -s' ); + ok( -s $afile > 20, ' -s' ); - unlink("afile"); + unlink($afile); } { ok( open(my $f, '-|', <afile"), 'open local $f, "+>", ...' ); + ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); binmode $f; - ok( -f "afile", ' -f' ); + ok( -f $afile, ' -f' ); ok( (print $f "SomeData\n"), ' print' ); is( tell($f), 9, ' tell' ); ok( seek($f,0,0), ' seek set' ); @@ -128,42 +129,42 @@ like( $@, qr/Bad filehandle:\s+afile/, ' right error' ); like( $@, qr/<\$f> line 1/, ' proper die message' ); ok( close($f), ' close' ); - unlink("afile"); + unlink($afile); } { - ok( open(local $f,'>', 'afile'), 'open local $f, ">", ...' ); + ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); ok( (print $f "a row\n"), ' print'); ok( close($f), ' close'); - ok( -s 'afile' < 10, ' -s' ); + ok( -s $afile < 10, ' -s' ); } { - ok( open(local $f,'>>', 'afile'), 'open local $f, ">>", ...' ); + ok( open(local $f,'>>', $afile), 'open local $f, ">>", ...' ); ok( (print $f "a row\n"), ' print'); ok( close($f), ' close'); - ok( -s 'afile' > 10, ' -s' ); + ok( -s $afile > 10, ' -s' ); } { - ok( open(local $f, '<', 'afile'), 'open local $f, "<", ...' ); + ok( open(local $f, '<', $afile), 'open local $f, "<", ...' ); my @rows = <$f>; is( scalar @rows, 2, ' readline list context' ); ok( close($f), ' close' ); } -ok( -s 'afile' < 20, ' -s' ); +ok( -s $afile < 20, ' -s' ); { - ok( open(local $f, '+<', 'afile'), 'open local $f, "+<", ...' ); + ok( open(local $f, '+<', $afile), 'open local $f, "+<", ...' ); my @rows = <$f>; is( scalar @rows, 2, ' readline list context' ); ok( seek($f, 0, 1), ' seek cur' ); ok( (print $f "yet another row\n"), ' print' ); ok( close($f), ' close' ); - ok( -s 'afile' > 20, ' -s' ); + ok( -s $afile > 20, ' -s' ); - unlink("afile"); + unlink($afile); } { @@ -197,8 +198,8 @@ EOC } -ok( !eval { open local $f, '<&', 'afile'; 1 }, 'local <& on non-filehandle'); -like( $@, qr/Bad filehandle:\s+afile/, ' right error' ); +ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); +like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); { local *F; @@ -282,19 +283,19 @@ SKIP: { use warnings 'layer'; local $SIG{__WARN__} = sub { $w = shift }; - eval { open(F, ">>>", "afile") }; + eval { open(F, ">>>", $afile) }; like($w, qr/Invalid separator character '>' in PerlIO layer spec/, "bad open (>>>) warning"); like($@, qr/Unknown open\(\) mode '>>>'/, "bad open (>>>) failure"); - eval { open(F, ">:u", "afile" ) }; + eval { open(F, ">:u", $afile ) }; like($w, qr/Unknown PerlIO layer "u"/, 'bad layer ">:u" warning'); - eval { open(F, "<:u", "afile" ) }; + eval { open(F, "<:u", $afile ) }; like($w, qr/Unknown PerlIO layer "u"/, 'bad layer "<:u" warning'); - eval { open(F, ":c", "afile" ) }; + eval { open(F, ":c", $afile ) }; like($@, qr/Unknown open\(\) mode ':c'/, 'bad layer ":c" failure'); } diff --git a/t/io/read.t b/t/io/read.t index 2665ecb..57e671d 100755 --- a/t/io/read.t +++ b/t/io/read.t @@ -12,7 +12,9 @@ die $@ if $@ and !$ENV{PERL_CORE_MINITEST}; plan tests => 2; -open(A,"+>a"); +my $tmpfile = tempfile(); + +open(A,"+>$tmpfile"); print A "_"; seek(A,0,0); @@ -23,12 +25,8 @@ read(A,$b,1,4); close(A); -unlink("a"); - is($b,"\000\000\000\000_"); # otherwise probably "\000bcd_" -unlink 'a'; - SKIP: { skip "no EBADF", 1 if (!exists &Errno::EBADF); diff --git a/t/io/tell.t b/t/io/tell.t index 4881d43..09b61a3 100755 --- a/t/io/tell.t +++ b/t/io/tell.t @@ -3,6 +3,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } print "1..28\n"; @@ -101,9 +102,7 @@ close(OTHER); # something else. ftell() on pipes, fifos, and sockets is defined to # return -1. -my $written = "tell_write.txt"; - -END { 1 while unlink($written) } +my $written = tempfile(); close($TST); open($tst,">$written") || die "Cannot open $written:$!"; diff --git a/t/io/through.t b/t/io/through.t index 60c75c9..a76c64d 100644 --- a/t/io/through.t +++ b/t/io/through.t @@ -90,7 +90,8 @@ sub testfile ($$$$$$) { my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; my @data = grep length, split /(.{1,$write_c})/s, $str; - open my $fh, '>', 'io_io.tmp' or die; + my $filename = tempfile(); + open my $fh, '>', $filename or die; select $fh; binmode $fh, ':crlf' if defined $main::use_crlf && $main::use_crlf == 1; @@ -106,7 +107,7 @@ sub testfile ($$$$$$) { die "Unrecognized write: '$how_w'"; } close $fh or die "close: $!"; - open $fh, '<', 'io_io.tmp' or die; + open $fh, '<', $filename or die; binmode $fh, ':crlf' if defined $main::use_crlf && $main::use_crlf == 1; testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); @@ -143,6 +144,4 @@ for my $s (1..2) { } } -unlink 'io_io.tmp'; - 1; diff --git a/t/io/utf8.t b/t/io/utf8.t index 2117338..07f829b 100755 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -17,7 +17,9 @@ plan(tests => 55); $| = 1; -open(F,"+>:utf8",'a'); +my $a_file = tempfile(); + +open(F,"+>:utf8",$a_file); print F chr(0x100).'£'; cmp_ok( tell(F), '==', 4, tell(F) ); print F "\n"; @@ -29,16 +31,16 @@ is( getc(F), "\n" ); seek(F,0,0); binmode(F,":bytes"); my $chr = chr(0xc4); -if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC +if (ord($a_file) == 193) { $chr = chr(0x8c); } # EBCDIC is( getc(F), $chr ); $chr = chr(0x80); -if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC +if (ord($a_file) == 193) { $chr = chr(0x41); } # EBCDIC is( getc(F), $chr ); $chr = chr(0xc2); -if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC +if (ord($a_file) == 193) { $chr = chr(0x80); } # EBCDIC is( getc(F), $chr ); $chr = chr(0xa3); -if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC +if (ord($a_file) == 193) { $chr = chr(0x44); } # EBCDIC is( getc(F), $chr ); is( getc(F), "\n" ); seek(F,0,0); @@ -55,25 +57,25 @@ close(F); $a = chr(300); # This *is* UTF-encoded $b = chr(130); # This is not. - open F, ">:utf8", 'a' or die $!; + open F, ">:utf8", $a_file or die $!; print F $a,"\n"; close F; - open F, "<:utf8", 'a' or die $!; + open F, "<:utf8", $a_file or die $!; $x = ; chomp($x); is( $x, chr(300) ); - open F, "a" or die $!; # Not UTF + open F, $a_file or die $!; # Not UTF binmode(F, ":bytes"); $x = ; chomp($x); $chr = chr(196).chr(172); - if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC + if (ord($a_file) == 193) { $chr = chr(141).chr(83); } # EBCDIC is( $x, $chr ); close F; - open F, ">:utf8", 'a' or die $!; + open F, ">:utf8", $a_file or die $!; binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. binmode(F,":utf8"); # turn UTF-8-ness back on print F $a; @@ -103,7 +105,7 @@ close(F); close F; - open F, "a" or die $!; # Not UTF + open F, $a_file or die $!; # Not UTF binmode(F, ":bytes"); $x = ; chomp($x); @@ -111,13 +113,13 @@ close(F); if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC is( $x, $chr, sprintf('(%vd)', $x) ); - open F, "<:utf8", "a" or die $!; + open F, "<:utf8", $a_file or die $!; $x = ; chomp($x); close F; is( $x, chr(300).chr(130), sprintf('(%vd)', $x) ); - open F, ">", "a" or die $!; + open F, ">", $a_file or die $!; binmode(F, ":bytes:"); # Now let's make it suffer. @@ -132,13 +134,13 @@ close(F); } # Hm. Time to get more evil. -open F, ">:utf8", "a" or die $!; +open F, ">:utf8", $a_file or die $!; print F $a; binmode(F, ":bytes"); print F chr(130)."\n"; close F; -open F, "<", "a" or die $!; +open F, "<", $a_file or die $!; binmode(F, ":bytes"); $x = ; chomp $x; $chr = v196.172.130; @@ -146,15 +148,15 @@ if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC is( $x, $chr ); # Right. -open F, ">:utf8", "a" or die $!; +open F, ">:utf8", $a_file or die $!; print F $a; close F; -open F, ">>", "a" or die $!; +open F, ">>", $a_file or die $!; binmode(F, ":bytes"); print F chr(130)."\n"; close F; -open F, "<", "a" or die $!; +open F, "<", $a_file or die $!; binmode(F, ":bytes"); $x = ; chomp $x; SKIP: { @@ -170,7 +172,7 @@ SKIP: { skip("EBCDIC doesn't complain", 2); } else { my @warnings; - open F, "<:utf8", "a" or die $!; + open F, "<:utf8", $a_file or die $!; $x = ; chomp $x; local $SIG{__WARN__} = sub { push @warnings, $_[0]; }; eval { sprintf "%vd\n", $x }; @@ -180,9 +182,9 @@ SKIP: { } close F; -unlink('a'); +unlink($a_file); -open F, ">:utf8", "a"; +open F, ">:utf8", $a_file; @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 unshift @a, chr(0); # ... and a null byte in front just for fun print F @a; @@ -191,7 +193,7 @@ close F; my $c; # read() should work on characters, not bytes -open F, "<:utf8", "a"; +open F, "<:utf8", $a_file; $a = 0; my $failed; for (@a) { @@ -219,7 +221,7 @@ is($failed, undef); local $SIG{__WARN__} = sub { $@ = shift }; undef $@; - open F, ">a"; + open F, ">$a_file"; binmode(F, ":bytes"); print F chr(0x100); close(F); @@ -227,14 +229,14 @@ is($failed, undef); like( $@, 'Wide character in print' ); undef $@; - open F, ">:utf8", "a"; + open F, ">:utf8", $a_file; print F chr(0x100); close(F); isnt( defined $@, !0 ); undef $@; - open F, ">a"; + open F, ">$a_file"; binmode(F, ":utf8"); print F chr(0x100); close(F); @@ -244,7 +246,7 @@ is($failed, undef); no warnings 'utf8'; undef $@; - open F, ">a"; + open F, ">$a_file"; print F chr(0x100); close(F); @@ -253,7 +255,7 @@ is($failed, undef); use warnings 'utf8'; undef $@; - open F, ">a"; + open F, ">$a_file"; binmode(F, ":bytes"); print F chr(0x100); close(F); @@ -262,9 +264,9 @@ is($failed, undef); } { - open F, ">:bytes","a"; print F "\xde"; close F; + open F, ">:bytes",$a_file; print F "\xde"; close F; - open F, "<:bytes", "a"; + open F, "<:bytes", $a_file; my $b = chr 0x100; $b .= ; is( $b, chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" ); @@ -272,9 +274,9 @@ is($failed, undef); } { - open F, ">:utf8","a"; print F chr 0x100; close F; + open F, ">:utf8",$a_file; print F chr 0x100; close F; - open F, "<:utf8", "a"; + open F, "<:utf8", $a_file; my $b = "\xde"; $b .= ; is( $b, chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" ); @@ -290,12 +292,12 @@ is($failed, undef); for my $u (@a) { for my $v (@a) { # print "# @$u - @$v\n"; - open F, ">a"; + open F, ">$a_file"; binmode(F, ":" . $u->[1]); print F chr($u->[0]); close F; - open F, "[1]); my $s = chr($v->[0]); @@ -312,7 +314,7 @@ is($failed, undef); { # [perl #23428] Somethings rotten in unicode semantics - open F, ">a"; + open F, ">$a_file"; binmode F, ":utf8"; syswrite(F, $a = chr(0x100)); close F; @@ -328,7 +330,7 @@ is($failed, undef); use warnings 'utf8'; undef $@; local $SIG{__WARN__} = sub { $@ = shift }; - open F, ">a"; + open F, ">$a_file"; binmode F; my ($chrE4, $chrF6) = (chr(0xE4), chr(0xF6)); if (ord('A') == 193) # EBCDIC @@ -336,7 +338,7 @@ is($failed, undef); print F "foo", $chrE4, "\n"; print F "foo", $chrF6, "\n"; close F; - open F, "<:utf8", "a"; + open F, "<:utf8", $a_file; undef $@; my $line = ; my ($chrE4, $chrF6) = ("E4", "F6"); @@ -349,8 +351,3 @@ is($failed, undef); "<:utf8 rcatline must warn about bad utf8"); close F; } - -END { - 1 while unlink "a"; - 1 while unlink "b"; -}