dslinux/user/perl/lib/File/Temp/t mktemp.t object.t posix.t security.t tempfile.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:42 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/File/Temp/t
In directory antilope:/tmp/cvs-serv17422/lib/File/Temp/t

Added Files:
	mktemp.t object.t posix.t security.t tempfile.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: mktemp.t ---
#!/usr/local/bin/perl -w

# Test for mktemp family of commands in File::Temp
# Use STANDARD safe level for these tests

use strict;
use Test;
BEGIN { plan tests => 9 }

use File::Spec;
use File::Path;
use File::Temp qw/ :mktemp unlink0 /;
use FileHandle;

ok(1);

# MKSTEMP - test

# Create file in temp directory
my $template = File::Spec->catfile(File::Spec->tmpdir, 'wowserXXXX');

(my $fh, $template) = mkstemp($template);

print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n";
# Check if the file exists
ok( (-e $template) );

# Autoflush
$fh->autoflush(1) if $] >= 5.006;

# Try printing something to the file
my $string = "woohoo\n";
print $fh $string;

# rewind the file
ok(seek( $fh, 0, 0));

# Read from the file
my $line = <$fh>;

# compare with previous string
ok($string, $line);

# Tidy up
# This test fails on Windows NT since it seems that the size returned by 
# stat(filehandle) does not always equal the size of the stat(filename)
# This must be due to caching. In particular this test writes 7 bytes
# to the file which are not recognised by stat(filename)
# Simply waiting 3 seconds seems to be enough for the system to update

if ($^O eq 'MSWin32') {
  sleep 3;
}
my $status = unlink0($fh, $template);
if ($status) {
  ok( $status );
} else {
  skip("Skip test failed probably due to \$TMPDIR being on NFS",1);
}

# MKSTEMPS
# File with suffix. This is created in the current directory so
# may be problematic on NFS

$template = "suffixXXXXXX";
my $suffix = ".dat";

($fh, my $fname) = mkstemps($template, $suffix);

print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n";
# Check if the file exists
ok( (-e $fname) );

# This fails if you are running on NFS
# If this test fails simply skip it rather than doing a hard failure
$status = unlink0($fh, $fname);

if ($status) {
  ok($status);
} else {
  skip("Skip test failed probably due to cwd being on NFS",1)
}

# MKDTEMP
# Temp directory

$template = File::Spec->catdir(File::Spec->tmpdir, 'tmpdirXXXXXX');

my $tmpdir = mkdtemp($template);

print "# MKDTEMP: Name is $tmpdir from template $template\n";

ok( (-d $tmpdir ) );

# Need to tidy up after myself
rmtree($tmpdir);

# MKTEMP
# Just a filename, not opened

$template = File::Spec->catfile(File::Spec->tmpdir, 'mytestXXXXXX');

my $tmpfile = mktemp($template);

print "# MKTEMP: Tempfile is $template -> $tmpfile\n";

# Okay if template no longer has XXXXX in


ok( ($tmpfile !~ /XXXXX$/) );

--- NEW FILE: posix.t ---
#!/usr/local/bin/perl -w
# Test for File::Temp - POSIX functions

use strict;
use Test;
BEGIN { plan tests => 7}

use File::Temp qw/ :POSIX unlink0 /;
use FileHandle;
ok(1);

# TMPNAM - scalar

print "# TMPNAM: in a scalar context: \n";
my $tmpnam = tmpnam();

# simply check that the file does not exist
# Not a 100% water tight test though if another program 
# has managed to create one in the meantime.
ok( !(-e $tmpnam ));

print "# TMPNAM file name: $tmpnam\n";

# TMPNAM list context
# Not strict posix behaviour
(my $fh, $tmpnam) = tmpnam();

print "# TMPNAM: in list context: $fh $tmpnam\n";

# File is opened - make sure it exists
ok( (-e $tmpnam ));

# Unlink it - a possible NFS issue again if TMPDIR is not a local disk
my $status = unlink0($fh, $tmpnam);
if ($status) {
  ok( $status );
} else {
  skip("Skip test failed probably due to \$TMPDIR being on NFS",1);
}

# TMPFILE

$fh = tmpfile();

if (defined $fh) {
  ok( $fh );
  print "# TMPFILE: tmpfile got FH $fh\n";

  $fh->autoflush(1) if $] >= 5.006;

  # print something to it
  my $original = "Hello a test\n";
  print "# TMPFILE: Wrote line: $original";
  print $fh $original
    or die "Error printing to tempfile\n";

  # rewind it
  ok( seek($fh,0,0) );

  # Read from it
  my $line = <$fh>;

  print "# TMPFILE: Read line: $line";
  ok( $original, $line);

  close($fh);

} else {
  # Skip all the remaining tests
  foreach (1..3) {
    skip("Skip test failed probably due to \$TMPDIR being on NFS",1);
  }
}





--- NEW FILE: tempfile.t ---
#!/usr/local/bin/perl -w
# Test for File::Temp - tempfile function

use strict;
use Test;
BEGIN { plan tests => 22}
use File::Spec;

# Will need to check that all files were unlinked correctly
# Set up an END block here to do it

# Arrays containing list of dirs/files to test
my (@files, @dirs, @still_there);

# And a test for files that should still be around
# These are tidied up
END {
  foreach (@still_there) {
    ok( -f $_ );
    ok( unlink( $_ ) );
    ok( !(-f $_) );
  }
}

# Loop over an array hoping that the files dont exist
END { foreach (@files) { ok( !(-e $_) )} }

# And a test for directories
END { foreach (@dirs)  { ok( !(-d $_) )} }

# Need to make sure that the END blocks are setup before
# the ones that File::Temp configures since END blocks are evaluated
# in revers order and we need to check the files *after* File::Temp
# removes them
use File::Temp qw/ tempfile tempdir/;

# Now we start the tests properly
ok(1);


# Tempfile
# Open tempfile in some directory, unlink at end
my ($fh, $tempfile) = tempfile(
			       UNLINK => 1,
			       SUFFIX => '.txt',
			      );

ok( (-f $tempfile) );
# Should still be around after closing
ok( close( $fh ) ); 
ok( (-f $tempfile) );
# Check again at exit
push(@files, $tempfile);

# TEMPDIR test
# Create temp directory in current dir
my $template = 'tmpdirXXXXXX';
print "# Template: $template\n";
my $tempdir = tempdir( $template ,
		       DIR => File::Spec->curdir,
		       CLEANUP => 1,
		     );

print "# TEMPDIR: $tempdir\n";

ok( (-d $tempdir) );
push(@dirs, $tempdir);

# Create file in the temp dir
($fh, $tempfile) = tempfile(
			    DIR => $tempdir,
			    UNLINK => 1,
			    SUFFIX => '.dat',
			   );

print "# TEMPFILE: Created $tempfile\n";

ok( (-f $tempfile));
push(@files, $tempfile);

# Test tempfile
# ..and again
($fh, $tempfile) = tempfile(
			    DIR => $tempdir,
			   );


ok( (-f $tempfile ));
push(@files, $tempfile);

# Test tempfile
# ..and another with changed permissions (read-only)
($fh, $tempfile) = tempfile(
                           DIR => $tempdir,
                          );
chmod 0444, $tempfile;

ok( (-f $tempfile ));
push(@files, $tempfile);

print "# TEMPFILE: Created $tempfile\n";

# and another (with template)

($fh, $tempfile) = tempfile( 'helloXXXXXXX',
			    DIR => $tempdir,
			    UNLINK => 1,
			    SUFFIX => '.dat',
			   );

print "# TEMPFILE: Created $tempfile\n";

ok( (-f $tempfile) );
push(@files, $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

# Would like to create a temp file and just retrieve the handle
# but the test is problematic since:
#  - We dont know the filename so we cant check that it is tidied
#    correctly
#  - The unlink0 required on unix for tempfile creation will fail
#    on NFS
# Try to do what we can.
# Tempfile croaks on error so we need an eval
$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" );

  # Close it - can not check it is gone since we dont know the name
  ok( close($fh) );

} else {
  skip "Skip Failed probably due to NFS", 1;
  skip "Skip Failed probably due to NFS", 1;
}

# Now END block will execute to test the removal of directories
print "# End of tests. Execute END blocks\n";


--- NEW FILE: security.t ---
#!/usr/bin/perl -w
# Test for File::Temp - Security levels

# Some of the security checking will not work on all platforms
# Test a simple open in the cwd and tmpdir foreach of the
# security levels

use Test;
BEGIN { plan tests => 13 }

use strict;
use File::Spec;

# Set up END block - this needs to happen before we load
# File::Temp since this END block must be evaluated after the
# END block configured by File::Temp
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 = ( (
		  # No sticky bits.
		  $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'os2' || $^O eq 'dos' || $^O eq 'mpeix' || $^O eq 'MacOS'
		  ) ? 1 : 0 );

# Can not run high security tests in perls before 5.6.0
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";
} elsif ($skipperl) {
  $skip = "Skip Perl version must be v5.6.0 for these tests";

}

print "# We will be skipping some tests : $skip\n" if $skip;

# start off with basic checking

File::Temp->safe_level( File::Temp::STANDARD );

print "# Testing with STANDARD security...\n";

&test_security(0);

# Try medium

File::Temp->safe_level( File::Temp::MEDIUM )
  unless $skip;

print "# Testing with MEDIUM security...\n";

# Now we need to start skipping tests
&test_security($skip);

# Try HIGH

File::Temp->safe_level( File::Temp::HIGH )
  unless $skip;

print "# Testing with HIGH security...\n";

&test_security($skip);

exit;

# Subroutine to open two temporary files.
# one is opened in the current dir and the other in the temp dir

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, 
				  DIR => File::Spec->tmpdir,
				  UNLINK => 1,
				);
			    };

  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);
  }

  # 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);
  }

}

--- NEW FILE: object.t ---
#!/usr/local/bin/perl -w
# Test for File::Temp - OO interface

use strict;
use Test::More tests => 26;
use File::Spec;

# Will need to check that all files were unlinked correctly
# Set up an END block here to do it

# Arrays containing list of dirs/files to test
my (@files, @dirs, @still_there);

# And a test for files that should still be around
# These are tidied up
END {
  foreach (@still_there) {
    ok( -f $_, "Check $_ exists" );
    ok( unlink( $_ ), "Unlinked $_" );
    ok( !(-f $_), "$_ no longer there");
  }
}

# Loop over an array hoping that the files dont exist
END { foreach (@files) { ok( !(-e $_), "File $_ should not be there" )} }

# And a test for directories
END { foreach (@dirs)  { ok( !(-d $_), "Directory $_ should not be there" ) } }

# Need to make sure that the END blocks are setup before
# the ones that File::Temp configures since END blocks are evaluated
# in reverse order and we need to check the files *after* File::Temp
# removes them
BEGIN {use_ok( "File::Temp" ); }

# Tempfile
# Open tempfile in some directory, unlink at end
my $fh = new File::Temp( SUFFIX => '.txt' );

ok( (-f "$fh"), "File $fh exists"  );
# Should still be around after closing
ok( close( $fh ), "Close file $fh" );
ok( (-f "$fh"), "File $fh still exists after close" );
# Check again at exit
push(@files, "$fh");

# TEMPDIR test
# Create temp directory in current dir
my $template = 'tmpdirXXXXXX';
print "# Template: $template\n";
my $tempdir = File::Temp::tempdir( $template ,
				   DIR => File::Spec->curdir,
				   CLEANUP => 1,
				 );

print "# TEMPDIR: $tempdir\n";

ok( (-d $tempdir), "Does $tempdir directory exist" );
push(@dirs, $tempdir);

# Create file in the temp dir
$fh = new File::Temp(
		     DIR => $tempdir,
		     SUFFIX => '.dat',
		    );

ok( $fh->unlink_on_destroy, "should unlink");
print "# TEMPFILE: Created $fh\n";

ok( (-f "$fh"), "File $fh exists in tempdir?");
push(@files, "$fh");

# Test tempfile
# ..and again (without unlinking it)
$fh = new File::Temp( DIR => $tempdir, UNLINK => 0 );

print "# TEMPFILE: Created $fh\n";
ok( (-f "$fh" ), "Second file $fh exists in tempdir [nounlink]?");
push(@files, "$fh");

# and another (with template)

$fh = new File::Temp( TEMPLATE => 'helloXXXXXXX',
		      DIR => $tempdir,
		      SUFFIX => '.dat',
		    );

print "# TEMPFILE: Created $fh\n";

ok( (-f "$fh"), "File $fh exists? [from template]" );
push(@files, "$fh");


# Create a temporary file that should stay around after
# it has been closed
$fh = new File::Temp( TEMPLATE => 'permXXXXXXX', UNLINK => 0);

print "# TEMPFILE: Created $fh\n";
ok( -f "$fh", "File $fh exists?" );
ok( close( $fh ), "Close file $fh" );
ok( ! $fh->unlink_on_destroy, "should not unlink");
push( @still_there, "$fh"); # check at END

# Now create a temp file that will remain when the object
# goes out of scope because of $KEEP_ALL
$fh = new File::Temp( TEMPLATE => 'permXXXXXXX', UNLINK => 1);

print "# TEMPFILE: Created $fh\n";
ok( -f "$fh", "File $fh exists?" );
ok( close( $fh ), "Close file $fh" );
ok( $fh->unlink_on_destroy, "should unlink (in principal)");
push( @still_there, "$fh"); # check at END
$File::Temp::KEEP_ALL = 1;

# Make sure destructors run
undef $fh;

# allow end blocks to run
$File::Temp::KEEP_ALL = 0;

# Now END block will execute to test the removal of directories
print "# End of tests. Execute END blocks\n";





More information about the dslinux-commit mailing list