diff options
author | David Golden <dagolden@cpan.org> | 2013-02-07 23:16:14 -0500 |
---|---|---|
committer | David Golden <dagolden@cpan.org> | 2013-02-07 23:16:14 -0500 |
commit | 46205598fd4365259edae4d52902d161f025d0c2 (patch) | |
tree | a3257a9ca2ca38181f7de67f92b084bb6ee8b49d /cpan | |
parent | f09d8c379a9d59fc38b2fc1517c6659ed99f544e (diff) | |
download | perl-46205598fd4365259edae4d52902d161f025d0c2.tar.gz |
Updated File::Temp from 0.22 to 0.22_90
Diffstat (limited to 'cpan')
-rw-r--r-- | cpan/File-Temp/Temp.pm | 132 | ||||
-rw-r--r-- | cpan/File-Temp/t/mktemp.t | 3 | ||||
-rw-r--r-- | cpan/File-Temp/t/object.t | 19 | ||||
-rw-r--r-- | cpan/File-Temp/t/posix.t | 3 | ||||
-rw-r--r-- | cpan/File-Temp/t/rmtree.t | 44 | ||||
-rw-r--r-- | cpan/File-Temp/t/security.t | 119 | ||||
-rw-r--r-- | cpan/File-Temp/t/tempfile.t | 64 |
7 files changed, 248 insertions, 136 deletions
diff --git a/cpan/File-Temp/Temp.pm b/cpan/File-Temp/Temp.pm index a2d4ae0759..38113f338c 100644 --- a/cpan/File-Temp/Temp.pm +++ b/cpan/File-Temp/Temp.pm @@ -30,8 +30,9 @@ C<_can_unlink_opened_file> method should be modified. Are the return values from C<stat> reliable? By default all the return values from C<stat> are compared when unlinking a temporary file using the filename and the handle. Operating systems other than -unix do not always have valid entries in all fields. If C<unlink0> fails -then the C<stat> comparison should be modified accordingly. +unix do not always have valid entries in all fields. If utility function +C<File::Temp::unlink0> fails then the C<stat> comparison should be +modified accordingly. =item * @@ -142,6 +143,7 @@ use 5.004; use strict; use Carp; use File::Spec 0.8; +use Cwd (); use File::Path qw/ rmtree /; use Fcntl 1.03; use IO::Seekable; # For SEEK_* @@ -203,7 +205,7 @@ Exporter::export_tags('POSIX','mktemp','seekable'); # Version number -$VERSION = '0.22'; +$VERSION = '0.22_90'; # This is a list of characters that can be used in random filenames @@ -635,7 +637,7 @@ sub _replace_XX { } # Internal routine to force a temp file to be writable after -# it is created so that we can unlink it. Windows seems to occassionally +# it is created so that we can unlink it. Windows seems to occasionally # force a file to be readonly when written to certain temp locations sub _force_writable { my $file = shift; @@ -750,7 +752,7 @@ sub _is_verysafe { } # To reach this point either, the _PC_CHOWN_RESTRICTED symbol - # was not avialable or the symbol was there but chown giveaway + # was not available or the symbol was there but chown giveaway # is allowed. Either way, we now have to test the entire tree for # safety. @@ -841,7 +843,7 @@ sub _can_do_level { # Arguments: # _deferred_unlink( $fh, $fname, $isdir ); # -# - filehandle (so that it can be expclicitly closed if open +# - filehandle (so that it can be explicitly closed if open # - filename (the thing we want to remove) # - isdir (flag to indicate that we are being given a directory) # [and hence no filehandle] @@ -868,12 +870,17 @@ sub _can_do_level { # Set up an end block to use these arrays END { local($., $@, $!, $^E, $?); - cleanup(); + cleanup(at_exit => 1); } - # Cleanup function. Always triggered on END but can be invoked - # manually. + # Cleanup function. Always triggered on END (with at_exit => 1) but + # can be invoked manually. sub cleanup { + my %h = @_; + my $at_exit = delete $h{at_exit}; + $at_exit = 0 if not defined $at_exit; + { my @k = sort keys %h; die "unrecognized parameters: @k" if @k } + if (!$KEEP_ALL) { # Files my @files = (exists $files_to_unlink{$$} ? @@ -893,17 +900,36 @@ sub _can_do_level { # Dirs my @dirs = (exists $dirs_to_unlink{$$} ? @{ $dirs_to_unlink{$$} } : () ); + my ($cwd, $cwd_to_remove); foreach my $dir (@dirs) { if (-d $dir) { # Some versions of rmtree will abort if you attempt to remove - # the directory you are sitting in. We protect that and turn it - # into a warning. We do this because this occurs during - # cleanup and so can not be caught by the user. + # the directory you are sitting in. For automatic cleanup + # at program exit, we avoid this by chdir()ing out of the way + # first. If not at program exit, it's best not to mess with the + # current directory, so just let it fail with a warning. + if ($at_exit) { + $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd; + my $abs = Cwd::abs_path($dir); + if ($abs eq $cwd) { + $cwd_to_remove = $dir; + next; + } + } eval { rmtree($dir, $DEBUG, 0); }; warn $@ if ($@ && $^W); } } + if (defined $cwd_to_remove) { + # We do need to clean up the current directory, and everything + # else is done, so get out of there and remove it. + my $root = File::Spec->rootdir; + chdir $root or die "cannot chdir to $root: $!"; + eval { rmtree($cwd_to_remove, $DEBUG, 0); }; + warn $@ if ($@ && $^W); + } + # clear the arrays @{ $files_to_unlink{$$} } = () if exists $files_to_unlink{$$}; @@ -928,6 +954,12 @@ sub _can_do_level { warn "Setting up deferred removal of $fname\n" if $DEBUG; + # make sure we save the absolute path for later cleanup + # OK to untaint because we only ever use this internally + # as a file path, never interpolating into the shell + $fname = Cwd::abs_path($fname); + ($fname) = $fname =~ /^(.*)$/; + # If we have a directory, check that it is a directory if ($isdir) { @@ -1011,6 +1043,7 @@ sub new { my $class = ref($proto) || $proto; # read arguments and convert keys to upper case + my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' ); my %args = @_; %args = map { uc($_), $args{$_} } keys %args; @@ -1020,7 +1053,10 @@ sub new { # template (store it in an array so that it will # disappear from the arg list of tempfile) - my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () ); + my @template = ( + exists $args{TEMPLATE} ? $args{TEMPLATE} : + $leading_template ? $leading_template : () + ); delete $args{TEMPLATE}; # Protect OPEN @@ -1081,7 +1117,14 @@ sub newdir { } else { $tempdir = tempdir( %options ); } + + # get a safe absolute path for cleanup, just like + # happens in _deferred_unlink + my $real_dir = Cwd::abs_path( $tempdir ); + ($real_dir) = $real_dir =~ /^(.*)$/; + return bless { DIRNAME => $tempdir, + REALNAME => $real_dir, CLEANUP => $cleanup, LAUNCHPID => $$, }, "File::Temp::Dir"; @@ -1140,7 +1183,7 @@ sub unlink_on_destroy { =item B<DESTROY> When the object goes out of scope, the destructor is called. This -destructor will attempt to unlink the file (using C<unlink1>) +destructor will attempt to unlink the file (using L<unlink1|"unlink1">) if the constructor was called with UNLINK set to 1 (the default state if UNLINK is not specified). @@ -1149,9 +1192,12 @@ No error is given if the unlink fails. If the object has been passed to a child process during a fork, the file will be deleted when the object goes out of scope in the parent. -For a temporary directory object the directory will be removed -unless the CLEANUP argument was used in the constructor (and set to -false) or C<unlink_on_destroy> was modified after creation. +For a temporary directory object the directory will be removed unless +the CLEANUP argument was used in the constructor (and set to false) or +C<unlink_on_destroy> was modified after creation. Note that if a temp +directory is your current directory, it cannot be removed - a warning +will be given in this case. C<chdir()> out of the directory before +letting the object go out of scope. If the global variable $KEEP_ALL is true, the file or directory will not be removed. @@ -1293,7 +1339,9 @@ Will croak() if there is an error. =cut sub tempfile { - + if ( @_ && $_[0] eq 'File::Temp' ) { + croak "'tempfile' can't be called as a method"; + } # Can not check for argument count since we can have any # number of args @@ -1378,7 +1426,7 @@ sub tempfile { # Create the file my ($fh, $path, $errstr); - croak "Error in tempfile() using $template: $errstr" + croak "Error in tempfile() using template $template: $errstr" unless (($fh, $path) = _gettemp($template, "open" => $options{'OPEN'}, "mkdir"=> 0 , @@ -1484,6 +1532,9 @@ Will croak() if there is an error. # ' sub tempdir { + if ( @_ && $_[0] eq 'File::Temp' ) { + croak "'tempdir' can't be called as a method"; + } # Can not check for argument count since we can have any # number of args @@ -1976,15 +2027,14 @@ sub unlink0 { # Make sure that the link count is zero # - Cygwin provides deferred unlinking, however, # on Win9x the link count remains 1 - # On NFS the link count may still be 1 but we cant know that - # we are on NFS - return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + # On NFS the link count may still be 1 but we can't know that + # we are on NFS. Since we can't be sure, we'll defer it - } else { - _deferred_unlink($fh, $path, 0); - return 1; + return 1 if $fh[3] == 0 || $^O eq 'cygwin'; } - + # fall-through if we can't unlink now + _deferred_unlink($fh, $path, 0); + return 1; } =item B<cmpstat> @@ -2135,6 +2185,11 @@ when the process exits but can be triggered manually if the caller is sure that none of the temp files are required. This method can be registered as an Apache callback. +Note that if a temp directory is your current directory, it cannot be +removed. C<chdir()> out of the directory first before calling +C<cleanup()>. (For the cleanup at program exit when the CLEANUP flag +is set, this happens automatically.) + On OSes where temp files are automatically removed when the temp file is closed, calling this function will have no effect other than to remove temporary directories (which may include temporary files). @@ -2230,7 +2285,7 @@ simply examine the return value of C<safe_level>. if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; } else { - # Dont allow this on perl 5.005 or earlier + # Don't allow this on perl 5.005 or earlier if ($] < 5.006 && $level != STANDARD) { # Cant do MEDIUM or HIGH checks croak "Currently requires perl 5.006 or newer to do the safe checks"; @@ -2316,10 +2371,12 @@ conditions. It's far more secure to use the filehandle alone and dispense with the filename altogether. If you need to pass the handle to something that expects a filename -then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary -programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl -programs. You will have to clear the close-on-exec bit on that file -descriptor before passing it to another process. +then on a unix system you can use C<"/dev/fd/" . fileno($fh)> for +arbitrary programs. Perl code that uses the 2-argument version of +C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you +will need to pass the filename. You will have to clear the +close-on-exec bit on that file descriptor before passing it to another +process. use Fcntl qw/F_SETFD F_GETFD/; fcntl($tmpfh, F_SETFD, 0) @@ -2355,6 +2412,11 @@ Note that if you have chdir'ed into the temporary directory and it is subsequently cleaned up (either in the END block or as part of object destruction), then you will get a warning from File::Path::rmtree(). +=head2 Taint mode + +If you need to run code under taint mode, updating to the latest +L<File::Spec> is highly recommended. + =head2 BINMODE The file returned by File::Temp will have been opened in binary mode @@ -2387,7 +2449,7 @@ the C<tempdir> function. Tim Jenness E<lt>tjenness@cpan.orgE<gt> -Copyright (C) 2007-2009 Tim Jenness. +Copyright (C) 2007-2010 Tim Jenness. Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same @@ -2437,12 +2499,12 @@ sub DESTROY { local($., $@, $!, $^E, $?); if ($self->unlink_on_destroy && $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { - if (-d $self->{DIRNAME}) { + if (-d $self->{REALNAME}) { # Some versions of rmtree will abort if you attempt to remove # the directory you are sitting in. We protect that and turn it # into a warning. We do this because this occurs during object # destruction and so can not be caught by the user. - eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); }; + eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); }; warn $@ if ($@ && $^W); } } @@ -2450,3 +2512,5 @@ sub DESTROY { 1; + +# vim: ts=2 sts=2 sw=2 et: diff --git a/cpan/File-Temp/t/mktemp.t b/cpan/File-Temp/t/mktemp.t index 2014e30717..dc49c8561b 100644 --- a/cpan/File-Temp/t/mktemp.t +++ b/cpan/File-Temp/t/mktemp.t @@ -4,8 +4,7 @@ # Use STANDARD safe level for these tests use strict; -use Test; -BEGIN { plan tests => 9 } +use Test::More tests => 9; use File::Spec; use File::Path; diff --git a/cpan/File-Temp/t/object.t b/cpan/File-Temp/t/object.t index 8cf37858cc..267ccd2806 100644 --- a/cpan/File-Temp/t/object.t +++ b/cpan/File-Temp/t/object.t @@ -2,7 +2,7 @@ # Test for File::Temp - OO interface use strict; -use Test::More tests => 30; +use Test::More tests => 33; use File::Spec; # Will need to check that all files were unlinked correctly @@ -33,6 +33,12 @@ END { foreach (@dirs) { ok( !(-d $_), "Directory $_ should not be there" ) } } # removes them BEGIN {use_ok( "File::Temp" ); } +# Check for misuse +eval { File::Temp->tempfile }; +like( $@, qr/can't be called as a method/, "File::Temp->tempfile error" ); +eval { File::Temp->tempdir }; +like( $@, qr/can't be called as a method/, "File::Temp->tempfile error" ); + # Tempfile # Open tempfile in some directory, unlink at end my $fh = new File::Temp( SUFFIX => '.txt' ); @@ -102,7 +108,16 @@ $fh = new File::Temp( TEMPLATE => 'helloXXXXXXX', print "# TEMPFILE: Created $fh\n"; -ok( (-f "$fh"), "File $fh exists? [from template]" ); +# and with a leading template +$fh = File::Temp->new( 'helloXXXXXXX', + DIR => $tempdir, + SUFFIX => '.dat', + ); + +print "# TEMPFILE: Created $fh\n"; + +ok( (-f "$fh"), "File $fh exists? [from leading template]" ); +like( "$fh", qr/hello/, "saw template" ); push(@files, "$fh"); diff --git a/cpan/File-Temp/t/posix.t b/cpan/File-Temp/t/posix.t index b63fb29140..07784046ad 100644 --- a/cpan/File-Temp/t/posix.t +++ b/cpan/File-Temp/t/posix.t @@ -2,8 +2,7 @@ # Test for File::Temp - POSIX functions use strict; -use Test; -BEGIN { plan tests => 7} +use Test::More tests => 7; use File::Temp qw/ :POSIX unlink0 /; use FileHandle; diff --git a/cpan/File-Temp/t/rmtree.t b/cpan/File-Temp/t/rmtree.t new file mode 100644 index 0000000000..c5c98d75e4 --- /dev/null +++ b/cpan/File-Temp/t/rmtree.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use Test::More tests => 1; + +use File::Spec; +use File::Path; +use File::Temp; + +rmtree "testing"; +mkdir "testing" or die "mkdir failed: $!"; +chdir "testing"; +mkdir "tmp" or die "mkdir failed: $!"; + +my $tempdirstr; +{ + my $dir = File::Temp->newdir( DIR => "tmp" ); + $tempdirstr = "$dir"; + + mkdir "hide" or die "mkdir failed: $!"; + chdir "hide"; +} + +chdir File::Spec->updir; +$tempdirstr = File::Spec->rel2abs($tempdirstr); +ok !-d $tempdirstr or diag dircontent("tmp", $tempdirstr); + +# cleanup +chdir File::Spec->updir; +rmtree( "testing" ); + +exit; + +sub dircontent { + my $dir = shift; + my $tempdirstr = shift; + my $str = "Contents of $dir (should not contain \"$tempdirstr\"):\n"; + opendir(my $DH, $dir) or die "opendir failed; $!"; + my @contents = grep { $_ !~ /^\.+/; } readdir($DH); + closedir($DH); + for my $ls (@contents) { + $str .= " $ls\n"; + } + return $str; +} diff --git a/cpan/File-Temp/t/security.t b/cpan/File-Temp/t/security.t index 736854f054..dee3df8781 100644 --- a/cpan/File-Temp/t/security.t +++ b/cpan/File-Temp/t/security.t @@ -5,8 +5,7 @@ # Test a simple open in the cwd and tmpdir foreach of the # security levels -use Test; -BEGIN { plan tests => 13 } +use Test::More tests => 12; use strict; use File::Spec; @@ -18,7 +17,6 @@ my @files; # list of files to remove END { foreach (@files) { ok( !(-e $_) )} } use File::Temp qw/ tempfile unlink0 /; -ok(1); # The high security tests must currently be skipped on some platforms my $skipplat = ( ( @@ -32,9 +30,9 @@ my $skipperl = ($] < 5.006 ? 1 : 0 ); # Determine whether we need to skip things and why my $skip = 0; if ($skipplat) { - $skip = "Skip Not supported on this platform"; + $skip = "Not supported on this platform"; } elsif ($skipperl) { - $skip = "Skip Perl version must be v5.6.0 for these tests"; + $skip = "Perl version must be v5.6.0 for these tests"; } @@ -46,26 +44,28 @@ File::Temp->safe_level( File::Temp::STANDARD ); print "# Testing with STANDARD security...\n"; -&test_security(0); +test_security(); -# Try medium +SKIP: { + skip $skip, 8 if $skip; -File::Temp->safe_level( File::Temp::MEDIUM ) - unless $skip; + # Try medium -print "# Testing with MEDIUM security...\n"; + File::Temp->safe_level( File::Temp::MEDIUM ); -# Now we need to start skipping tests -&test_security($skip); + print "# Testing with MEDIUM security...\n"; -# Try HIGH + # Now we need to start skipping tests + test_security(); -File::Temp->safe_level( File::Temp::HIGH ) - unless $skip; + # Try HIGH -print "# Testing with HIGH security...\n"; + File::Temp->safe_level( File::Temp::HIGH ); -&test_security($skip); + print "# Testing with HIGH security...\n"; + + test_security(); +} exit; @@ -74,23 +74,6 @@ exit; sub test_security { - # Read in the skip flag - my $skip = shift; - - # If we are skipping we need to simply fake the correct number - # of tests -- we dont use skip since the tempfile() commands will - # fail with MEDIUM/HIGH security before the skip() command would be run - if ($skip) { - - skip($skip,1); - skip($skip,1); - - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; - - return; - } - # Create the tempfile my $template = "tmpXXXXX"; my ($fh1, $fname1) = eval { tempfile ( $template, @@ -99,42 +82,40 @@ sub test_security { ); }; - if (defined $fname1) { - print "# fname1 = $fname1\n"; - ok( (-e $fname1) ); - push(@files, $fname1); # store for end block - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - chomp($@); - my $skip2 = "Skip: " . File::Spec->tmpdir() . " possibly insecure: $@. " . - "See INSTALL under 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); + SKIP: { + if (defined $fname1) { + print "# fname1 = $fname1\n"; + ok( (-e $fname1) ); + push(@files, $fname1); # store for end block + } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { + chomp($@); + my $msg = File::Spec->tmpdir() . " possibly insecure: $@"; + skip $msg, 2; # one here and one in END + } else { + ok(0); + } } - # Explicitly - if ( $< < File::Temp->top_system_uid() ){ - skip("Skip Test inappropriate for root", 1); - eval q{ END { skip($skip,1); } 1; } || die; - return; - } - my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); }; - if (defined $fname2) { - print "# fname2 = $fname2\n"; - ok( (-e $fname2) ); - push(@files, $fname2); # store for end block - close($fh2); - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - chomp($@); - my $skip2 = "Skip: current directory possibly insecure: $@. " . - "See INSTALL under 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); + SKIP: { + # Explicitly + if ( $< < File::Temp->top_system_uid() ){ + skip("Skip Test inappropriate for root", 2); + return; + } + my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); }; + if (defined $fname2) { + print "# fname2 = $fname2\n"; + ok( (-e $fname2) ); + push(@files, $fname2); # store for end block + close($fh2); + } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { + chomp($@); + my $msg = "current directory possibly insecure: $@"; + skip $msg, 2; # one here and one in END + } else { + ok(0); + } } - } + +# vim: ts=2 sts=2 sw=2 et: diff --git a/cpan/File-Temp/t/tempfile.t b/cpan/File-Temp/t/tempfile.t index 7021645704..7698806348 100644 --- a/cpan/File-Temp/t/tempfile.t +++ b/cpan/File-Temp/t/tempfile.t @@ -2,9 +2,9 @@ # Test for File::Temp - tempfile function use strict; -use Test; -BEGIN { plan tests => 22} +use Test::More tests => 24; use File::Spec; +use Cwd qw/ cwd /; # Will need to check that all files were unlinked correctly # Set up an END block here to do it @@ -16,17 +16,18 @@ my (@files, @dirs, @still_there); # These are tidied up END { foreach (@still_there) { - ok( -f $_ ); - ok( unlink( $_ ) ); - ok( !(-f $_) ); + ($_) = /(^.*)/; # untaint for testing under taint mode + ok( -f $_, "File $_ is still present" ); + ok( unlink( $_ ), "Unlink file" ); + ok( !(-f $_), "File is no longer present" ); } } # Loop over an array hoping that the files dont exist -END { foreach (@files) { ok( !(-e $_) )} } +END { foreach (@files) { ok( !(-e $_), "File $_ should not be present" )} } # And a test for directories -END { foreach (@dirs) { ok( !(-d $_) )} } +END { foreach (@dirs) { ok( !(-d $_), "Dir $_ should not be present" )} } # Need to make sure that the END blocks are setup before # the ones that File::Temp configures since END blocks are evaluated @@ -35,7 +36,7 @@ END { foreach (@dirs) { ok( !(-d $_) )} } use File::Temp qw/ tempfile tempdir/; # Now we start the tests properly -ok(1); +ok(1, "Start test"); # Tempfile @@ -45,10 +46,10 @@ my ($fh, $tempfile) = tempfile( SUFFIX => '.txt', ); -ok( (-f $tempfile) ); +ok( (-f $tempfile), "Tempfile exists" ); # Should still be around after closing -ok( close( $fh ) ); -ok( (-f $tempfile) ); +ok( close( $fh ), "Tempfile closed" ); +ok( (-f $tempfile), "Tempfile exists" ); # Check again at exit push(@files, $tempfile); @@ -63,8 +64,8 @@ my $tempdir = tempdir( $template , print "# TEMPDIR: $tempdir\n"; -ok( (-d $tempdir) ); -push(@dirs, $tempdir); +ok( (-d $tempdir), "Local tempdir exists" ); +push(@dirs, File::Spec->rel2abs($tempdir)); # Create file in the temp dir ($fh, $tempfile) = tempfile( @@ -75,8 +76,8 @@ push(@dirs, $tempdir); print "# TEMPFILE: Created $tempfile\n"; -ok( (-f $tempfile)); -push(@files, $tempfile); +ok( (-f $tempfile), "Local temp file exists with .dat extension"); +push(@files, File::Spec->rel2abs($tempfile)); # Test tempfile # ..and again @@ -85,8 +86,8 @@ push(@files, $tempfile); ); -ok( (-f $tempfile )); -push(@files, $tempfile); +ok( (-f $tempfile ), "Local tempfile in tempdir exists"); +push(@files, File::Spec->rel2abs($tempfile)); # Test tempfile # ..and another with changed permissions (read-only) @@ -95,8 +96,8 @@ push(@files, $tempfile); ); chmod 0444, $tempfile; -ok( (-f $tempfile )); -push(@files, $tempfile); +ok( (-f $tempfile ), "Local tempfile in tempdir exists read-only"); +push(@files, File::Spec->rel2abs($tempfile)); print "# TEMPFILE: Created $tempfile\n"; @@ -110,17 +111,17 @@ print "# TEMPFILE: Created $tempfile\n"; print "# TEMPFILE: Created $tempfile\n"; -ok( (-f $tempfile) ); -push(@files, $tempfile); +ok( (-f $tempfile), "Local tempfile in tempdir with .dat extension exists" ); +push(@files, File::Spec->rel2abs($tempfile)); # Create a temporary file that should stay around after # it has been closed ($fh, $tempfile) = tempfile( 'permXXXXXXX', UNLINK => 0 ); print "# TEMPFILE: Created $tempfile\n"; -ok( -f $tempfile ); -ok( close( $fh ) ); -push( @still_there, $tempfile); # check at END +ok( -f $tempfile, "Long-lived temp file" ); +ok( close( $fh ), "Close long-lived temp file" ); +push( @still_there, File::Spec->rel2abs($tempfile) ); # check at END # Would like to create a temp file and just retrieve the handle # but the test is problematic since: @@ -135,16 +136,25 @@ $fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) }; if ($fh) { # print something to it to make sure something is there - ok( print $fh "Test\n" ); + ok( print($fh "Test\n"), "Write to temp file" ); # Close it - can not check it is gone since we dont know the name - ok( close($fh) ); + ok( close($fh), "Close temp file" ); } else { skip "Skip Failed probably due to NFS", 1; skip "Skip Failed probably due to NFS", 1; } +# Create temp directory and chdir to it; it should still be removed on exit. +$tempdir = tempdir(CLEANUP => 1); + +print "# TEMPDIR: $tempdir\n"; + +ok( (-d $tempdir), "Temp directory in temp dir" ); +chdir $tempdir or die $!; +push(@dirs, File::Spec->rel2abs($tempdir)); + # Now END block will execute to test the removal of directories -print "# End of tests. Execute END blocks\n"; +print "# End of tests. Execute END blocks in directory ". cwd() ."\n"; |