From: Nicholas Clark Date: Thu, 7 Aug 2008 10:12:44 +0000 (+0000) Subject: Use test.pl's tempfile(). X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1c25d394345c1b97c9cfd949fe3d2e3296fd9681;p=p5sagit%2Fp5-mst-13.2.git Use test.pl's tempfile(). p4raw-id: //depot/perl@34180 --- diff --git a/t/op/closure.t b/t/op/closure.t index d1cab95..5e3bf45 100755 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -463,9 +463,8 @@ END } } else { # No fork(). Do it the hard way. - my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; - my $errfile = "terr$$"; $errfile++ while -e $errfile; - my @tmpfiles = ($cmdfile, $errfile); + my $cmdfile = tempfile(); + my $errfile = tempfile(); open CMD, ">$cmdfile"; print CMD $code; close CMD; my $cmd = which_perl(); $cmd .= " -w $cmdfile 2>$errfile"; @@ -477,18 +476,15 @@ END { local $/; $output = join '', } close PERL; } else { - my $outfile = "tout$$"; $outfile++ while -e $outfile; - push @tmpfiles, $outfile; + my $outfile = tempfile(); system "$cmd >$outfile"; { local $/; open IN, $outfile; $output = ; close IN } } if ($?) { printf "not ok: exited with error code %04X\n", $?; - $debugging or do { 1 while unlink @tmpfiles }; exit; } { local $/; open IN, $errfile; $errors = ; close IN } - 1 while unlink @tmpfiles; } print $output; print STDERR $errors; diff --git a/t/op/dbm.t b/t/op/dbm.t index e6545fa..2403370 100644 --- a/t/op/dbm.t +++ b/t/op/dbm.t @@ -13,38 +13,43 @@ plan tests => 4; # This is [20020104.007] "coredump on dbmclose" +my $filename = tempfile(); + my $prog = <<'EOC'; package Foo; +$filename = '@@@@'; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless($self,$class); my %LT; - dbmopen(%LT, "dbmtest", 0666) || - die "Can't open dbmtest because of $!\n"; + dbmopen(%LT, $filename, 0666) || + die "Can't open $filename because of $!\n"; $self->{'LT'} = \%LT; return $self; } sub DESTROY { my $self = shift; dbmclose(%{$self->{'LT'}}); - 1 while unlink 'dbmtest'; - 1 while unlink ; + 1 while unlink $filename; + 1 while unlink glob "$filename.*"; print "ok\n"; } package main; $test = Foo->new(); # must be package var EOC +$prog =~ s/\@\@\@\@/$filename/; + fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explict require'); fresh_perl_is($prog, 'ok', {}, 'implicit require'); $prog = <<'EOC'; @INC = (); -dbmopen(%LT, "dbmtest", 0666); -1 while unlink 'dbmtest'; -1 while unlink ; +dbmopen(%LT, $filename, 0666); +1 while unlink $filename; +1 while unlink glob "$filename.*"; die "Failed to fail!"; EOC diff --git a/t/op/eval.t b/t/op/eval.t index d3241e6..23725d5 100755 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -3,6 +3,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } print "1..98\n"; @@ -38,11 +39,12 @@ $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; $ans = eval $fact; if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";} -open(try,'>Op.eval'); -print try 'print "ok 10\n"; unlink "Op.eval";',"\n"; +my $tempfile = tempfile(); +open(try,'>',$tempfile); +print try 'print "ok 10\n";',"\n"; close try; -do './Op.eval'; print $@; +do "./$tempfile"; print $@; # Test the singlequoted eval optimizer @@ -500,15 +502,16 @@ print "ok $test # length of \$@ after eval\n"; $test++; # Check if eval { 1 }; compeltly resets $@ if (eval "use Devel::Peek; 1;") { - - open PROG, ">", "peek_eval_$$.t" or die "Can't create test file"; - print PROG <<'END_EVAL_TEST'; + $tempfile = tempfile(); + $outfile = tempfile(); + open PROG, ">", $tempfile or die "Can't create test file"; + my $prog = <<'END_EVAL_TEST'; use Devel::Peek; $! = 0; $@ = $!; my $ok = 0; open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; - if (open(OUT,">peek_eval$$")) { + if (open(OUT, '>', '@@@@')) { open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; Dump($@); print STDERR "******\n"; @@ -518,7 +521,7 @@ if (eval "use Devel::Peek; 1;") { Dump($@); open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; close(OUT); - if (open(IN, "peek_eval$$")) { + if (open(IN, '<', '@@@@')) { local $/; my $in = ; my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2); @@ -528,18 +531,16 @@ if (eval "use Devel::Peek; 1;") { } print $ok; - END { - 1 while unlink("peek_eval$$"); - } END_EVAL_TEST + $prog =~ s/\@\@\@\@/$outfile/g; + print PROG $prog; close PROG; - my $ok = runperl(progfile => "peek_eval_$$.t"); + my $ok = runperl(progfile => $tempfile); print "not " unless $ok; print "ok $test # eval { 1 } completly resets \$@\n"; $test++; - 1 while unlink("peek_eval_$$.t"); } else { print "ok $test # skipped - eval { 1 } completly resets \$@"; diff --git a/t/op/fork.t b/t/op/fork.t index a19b260..9fe8107 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -11,6 +11,7 @@ BEGIN { exit 0; } $ENV{PERL5LIB} = "../lib"; + require './test.pl'; } if ($^O eq 'mpeix') { @@ -24,9 +25,8 @@ undef $/; @prgs = split "\n########\n", ; print "1..", scalar @prgs, "\n"; -$tmpfile = "forktmp000"; -1 while -f ++$tmpfile; -END { close TEST; unlink $tmpfile if $tmpfile; } +$tmpfile = tempfile(); +END { close TEST } $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat')); @@ -54,8 +54,8 @@ for (@prgs){ } $status = $?; $results =~ s/\n+$//; - $results =~ s/at\s+forktmp\d+\s+line/at - line/g; - $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; + $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; + $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; diff --git a/t/op/goto.t b/t/op/goto.t index 9254d7c..c79b424 100755 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -205,7 +205,7 @@ is($ok, 1, 'goto in for(;;) with continuation'); # bug #22299 - goto in require doesn't find label -open my $f, ">goto01.pm" or die; +open my $f, ">Op_goto01.pm" or die; print $f <<'EOT'; package goto01; goto YYY; @@ -215,9 +215,9 @@ YYY: print "OK\n"; EOT close $f; -$r = runperl(prog => 'use goto01; print qq[DONE\n]'); +$r = runperl(prog => 'use Op_goto01; print qq[DONE\n]'); is($r, "OK\nDONE\n", "goto within use-d file"); -unlink "goto01.pm"; +unlink "Op_goto01.pm"; # test for [perl #24108] $ok = 1; diff --git a/t/op/inccode.t b/t/op/inccode.t index 45022ff..60c3581 100644 --- a/t/op/inccode.t +++ b/t/op/inccode.t @@ -25,12 +25,8 @@ use File::Spec; require "test.pl"; plan(tests => 49 + !$minitest * (3 + 14 * $can_fork)); -my @tempfiles = (); - sub get_temp_fh { - my $f = "DummyModule0000"; - 1 while -e ++$f; - push @tempfiles, $f; + my $f = tempfile(); open my $fh, ">$f" or die "Can't create $f: $!"; print $fh "package ".substr($_[0],0,-3).";\n1;\n"; print $fh $_[1] if @_ > 1; @@ -39,8 +35,6 @@ sub get_temp_fh { return $fh; } -END { 1 while unlink @tempfiles } - sub fooinc { my ($self, $filename) = @_; if (substr($filename,0,3) eq 'Foo') { diff --git a/t/op/lfs.t b/t/op/lfs.t index 8f022b8..2de965f 100644 --- a/t/op/lfs.t +++ b/t/op/lfs.t @@ -11,6 +11,7 @@ BEGIN { print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } + require './test.pl'; } use strict; @@ -18,11 +19,12 @@ use strict; our @s; our $fail; +my $big0 = tempfile(); +my $big1 = tempfile(); +my $big2 = tempfile(); + sub zap { close(BIG); - unlink("big"); - unlink("big1"); - unlink("big2"); } sub bye { @@ -82,33 +84,33 @@ my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2); # consume less blocks than one megabyte (assuming nobody has # one megabyte blocks...) -open(BIG, ">big1") or - do { warn "open big1 failed: $!\n"; bye }; +open(BIG, ">$big1") or + do { warn "open $big1 failed: $!\n"; bye }; binmode(BIG) or - do { warn "binmode big1 failed: $!\n"; bye }; + do { warn "binmode $big1 failed: $!\n"; bye }; seek(BIG, 1_000_000, $SEEK_SET) or - do { warn "seek big1 failed: $!\n"; bye }; + do { warn "seek $big1 failed: $!\n"; bye }; print BIG "big" or - do { warn "print big1 failed: $!\n"; bye }; + do { warn "print $big1 failed: $!\n"; bye }; close(BIG) or - do { warn "close big1 failed: $!\n"; bye }; + do { warn "close $big1 failed: $!\n"; bye }; -my @s1 = stat("big1"); +my @s1 = stat($big1); print "# s1 = @s1\n"; -open(BIG, ">big2") or - do { warn "open big2 failed: $!\n"; bye }; +open(BIG, ">$big2") or + do { warn "open $big2 failed: $!\n"; bye }; binmode(BIG) or - do { warn "binmode big2 failed: $!\n"; bye }; + do { warn "binmode $big2 failed: $!\n"; bye }; seek(BIG, 2_000_000, $SEEK_SET) or - do { warn "seek big2 failed; $!\n"; bye }; + do { warn "seek $big2 failed; $!\n"; bye }; print BIG "big" or - do { warn "print big2 failed; $!\n"; bye }; + do { warn "print $big2 failed; $!\n"; bye }; close(BIG) or - do { warn "close big2 failed; $!\n"; bye }; + do { warn "close $big2 failed; $!\n"; bye }; -my @s2 = stat("big2"); +my @s2 = stat($big2); print "# s2 = @s2\n"; @@ -129,13 +131,13 @@ print "# we seem to have sparse files...\n"; $ENV{LC_ALL} = "C"; my $r = system '../perl', '-e', <<'EOF'; -open(BIG, ">big"); +open(BIG, ">$big0"); seek(BIG, 5_000_000_000, 0); -print BIG "big"; +print BIG $big0; exit 0; EOF -open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; +open(BIG, ">$big0") or do { warn "open failed: $!\n"; bye }; binmode BIG; if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { my $err = $r ? 'signal '.($r & 0x7f) : $!; @@ -160,7 +162,7 @@ unless ($print && $close) { bye(); } -@s = stat("big"); +@s = stat($big0); print "# @s\n"; @@ -169,7 +171,7 @@ unless ($s[7] == 5_000_000_003) { bye(); } -sub fail () { +sub fail { print "not "; $fail++; } @@ -202,16 +204,16 @@ $fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; -fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize +fail unless -s $big0 == 5_000_000_003; # exercizes pp_ftsize print "ok 2\n"; -fail unless -e "big"; +fail unless -e $big0; print "ok 3\n"; -fail unless -f "big"; +fail unless -f $big0; print "ok 4\n"; -open(BIG, "big") or do { warn "open failed: $!\n"; bye }; +open(BIG, $big0) or do { warn "open failed: $!\n"; bye }; binmode BIG; fail unless seek(BIG, 4_500_000_000, $SEEK_SET); @@ -270,9 +272,8 @@ bye(); # does the necessary cleanup END { # unlink may fail if applied directly to a large file # be paranoid about leaving 5 gig files lying around - open(BIG, ">big"); # truncate + open(BIG, ">$big0"); # truncate close(BIG); - 1 while unlink "big"; # standard portable idiom } # eof diff --git a/t/op/mydef.t b/t/op/mydef.t index f250ff6..444bf4a 100644 --- a/t/op/mydef.t +++ b/t/op/mydef.t @@ -3,12 +3,13 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } print "1..70\n"; my $test = 0; -sub ok ($$) { +sub ok ($@) { my ($ok, $name) = @_; ++$test; print $ok ? "ok $test - $name\n" : "not ok $test - $name\n"; @@ -175,8 +176,7 @@ $_ = "global"; ::ok( $1 eq 'notmain', '...m// defaults to our $_ in main::' ); } -my $file = 'dolbar1.tmp'; -END { unlink $file; } +my $file = tempfile(); { open my $_, '>', $file or die "Can't open $file: $!"; print $_ "hello\n"; diff --git a/t/op/read.t b/t/op/read.t index 8235bc2..23f1b51 100755 --- a/t/op/read.t +++ b/t/op/read.t @@ -31,9 +31,7 @@ my $has_perlio = !eval { !$Config::Config{useperlio} }; -my $tmpfile = 'Op_read.tmp'; - -END { 1 while unlink $tmpfile } +my $tmpfile = tempfile(); my (@values, @buffers) = ('', ''); @@ -56,7 +54,6 @@ foreach my $value (@values) { skip "Needs :utf8 layer but no perlio", 2 * @offsets * @lengths if $utf8 and !$has_perlio; - 1 while unlink $tmpfile; open FH, ">$tmpfile" or die "Can't open $tmpfile: $!"; binmode FH, "utf8" if $utf8; print FH $value; diff --git a/t/op/readline.t b/t/op/readline.t index 0d6598f..1069a97 100644 --- a/t/op/readline.t +++ b/t/op/readline.t @@ -12,11 +12,11 @@ eval { for (\2) { $_ = } }; like($@, 'Modification of a read-only value attempted', '[perl #19566]'); { - open A,"+>a"; $a = 3; + my $file = tempfile(); + open A,'+>',$file; $a = 3; is($a .= , 3, '#21628 - $a .= , A eof'); close A; $a = 4; is($a .= , 4, '#21628 - $a .= , A closed'); - unlink "a"; } # 82 is chosen to exceed the length for sv_grow in do_readline (80) diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 36c63ef..c103812 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -8,6 +8,7 @@ chdir 't' if -d 't'; @INC = '../lib'; +require './test.pl'; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; @@ -20,9 +21,7 @@ undef $/; @prgs = split "\n########\n", ; print "1..", scalar @prgs, "\n"; -$tmpfile = "runltmp000"; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile; } } +$tmpfile = tempfile(); for (@prgs){ my $switch = ""; @@ -45,7 +44,7 @@ for (@prgs){ my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN - $results =~ s/runltmp\d+/-/g; + $results =~ s/$::tempfile_regexp/-/g; $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg $expected =~ s/\n+$//; if ($results ne $expected) { diff --git a/t/op/stat.t b/t/op/stat.t index d238855..a225de4 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -38,8 +38,8 @@ my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE, my $Curdir = File::Spec->curdir; -my $tmpfile = 'Op_stat.tmp'; -my $tmpfile_link = $tmpfile.'2'; +my $tmpfile = tempfile(); +my $tmpfile_link = tempfile(); chmod 0666, $tmpfile; 1 while unlink $tmpfile; diff --git a/t/op/taint.t b/t/op/taint.t index b2688cf..f578423 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -285,7 +285,7 @@ my $TEST = catfile(curdir(), 'TEST'); # How about command-line arguments? The problem is that we don't # always get some, so we'll run another process with some. SKIP: { - my $arg = catfile(curdir(), "arg$$"); + my $arg = catfile(curdir(), tempfile()); open PROG, "> $arg" or die "Can't create $arg: $!"; print PROG q{ eval { join('', @ARGV), kill 0 }; @@ -418,8 +418,7 @@ SKIP: { test !eval { require $foo }, 'require'; test $@ =~ /^Insecure dependency/, $@; - my $filename = "./taintB$$"; # NB: $filename isn't tainted! - END { unlink $filename if defined $filename } + my $filename = tempfile(); # NB: $filename isn't tainted! $foo = $filename . $TAINT; unlink $filename; # in any case @@ -506,8 +505,7 @@ SKIP: { my $foo = "x" x 979; taint_these $foo; local *FOO; - my $temp = "./taintC$$"; - END { unlink $temp } + my $temp = tempfile(); test open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; test !eval { ioctl FOO, $TAINT0, $foo }, 'ioctl';