Integrate with Sarathy.

p4raw-id: //depot/cfgperl@6086

6 files changed, 403 insertions, 10 deletions

diff --git a/t/lib/ftmp-mktemp.t b/t/lib/ftmp-mktemp.t
new file mode 100755
index 0000000000..c660475709
--- /dev/null
+++ b/t/lib/ftmp-mktemp.t
@@ -0,0 +1,101 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}
+
+# 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 /;
+
+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)
+
+if ($^O eq 'MSWin32') {
+  sleep 3;
+}
+ok( unlink0($fh, $template) );
+
+
+# MKSTEMPS
+# File with suffix. This is created in the current directory
+
+$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) );
+
+ok( unlink0($fh, $fname) ); 
+
+
+# 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$/) );
diff --git a/t/lib/ftmp-posix.t b/t/lib/ftmp-posix.t
new file mode 100755
index 0000000000..f28785e87a
--- /dev/null
+++ b/t/lib/ftmp-posix.t
@@ -0,0 +1,66 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}
+
+# Test for File::Temp - POSIX functions
+
+use strict;
+use Test;
+BEGIN { plan tests => 7}
+
+use File::Temp qw/ :POSIX unlink0 /;
+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 array context
+# Not strict posix behaviour
+(my $fh, $tmpnam) = tmpnam();
+
+print "# TMPNAM: in array context: $fh $tmpnam\n";
+
+# File is opened - make sure it exists
+ok( (-e $tmpnam ));
+
+# Unlink it 
+ok( unlink0($fh, $tmpnam) );
+
+# TMPFILE
+
+$fh = tmpfile();
+
+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);
diff --git a/t/lib/ftmp-security.t b/t/lib/ftmp-security.t
new file mode 100755
index 0000000000..50e177958a
--- /dev/null
+++ b/t/lib/ftmp-security.t
@@ -0,0 +1,119 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}
+
+# 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 strict;
+use Test;
+BEGIN { plan tests => 13}
+
+use File::Spec;
+use File::Temp qw/ tempfile unlink0 /;
+ok(1);
+
+# The high security tests must currently be skipped on Windows
+my $skipplat = ( $^O eq 'MSWin32' ? 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;
+  }
+
+
+  # End blocks are evaluated in reverse order
+  # If I want to check that the file was unlinked by the autmoatic
+  # feature of the module I have to set up the end block before 
+  # creating the file.
+  # Use quoted end block to retain access to lexicals
+  my @files;
+
+  eval q{ END { foreach (@files) { ok( !(-e $_) )} } 1; } || die; 
+
+
+  my $template = "temptestXXXXXXXX";
+  my ($fh1, $fname1) = tempfile ( $template, 
+				  DIR => File::Spec->curdir,
+				  UNLINK => 1,
+				);
+  print "# Fname1 = $fname1\n";
+  ok( ( -e $fname1) );
+
+  # Explicitly 
+  my ($fh2, $fname2) = tempfile ($template,  UNLINK => 1 );
+  ok( (-e $fname2) );
+  close($fh2);
+
+  # Store filenames for the end block
+  push(@files, $fname1, $fname2);
+
+
+
+}
diff --git a/t/lib/ftmp-tempfile.t b/t/lib/ftmp-tempfile.t
new file mode 100755
index 0000000000..9c0de8b955
--- /dev/null
+++ b/t/lib/ftmp-tempfile.t
@@ -0,0 +1,92 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}
+
+# Test for File::Temp - tempfile function
+
+use strict;
+use Test;
+BEGIN { plan tests => 10}
+use File::Spec;
+use File::Temp qw/ tempfile tempdir/;
+
+# Will need to check that all files were unlinked correctly
+# Set up an END block here to do it (since the END blocks
+# set up by File::Temp will be evaluated in reverse order we
+# set ours up first....
+
+# Loop over an array hoping that the files dont exist
+my @files;
+eval q{ END { foreach (@files) { ok( !(-e $_) )} } 1; } || die; 
+
+# And a test for directories
+my @dirs;
+eval q{ END { foreach (@dirs) { ok( !(-d $_) )} } 1; } || die; 
+
+
+# Tempfile
+# Open tempfile in some directory, unlink at end
+my ($fh, $tempfile) = tempfile(
+			       UNLINK => 1,
+			       SUFFIX => '.txt',
+			      );
+
+ok( (-f $tempfile) );
+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);
+
+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);
+
+# no tests yet to make sure that the END{} blocks correctly remove
+# the files
diff --git a/t/lib/peek.t b/t/lib/peek.t
index ecba70516c..255512fac5 100644
--- a/t/lib/peek.t
+++ b/t/lib/peek.t
@@ -15,12 +15,14 @@ use Devel::Peek;
 print "1..17\n";
 
 our $DEBUG = 0;
+open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
 
 sub do_test {
     my $pattern = pop;
     if (open(OUT,">peek$$")) {
-	open(STDERR,">&OUT");
+	open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
 	Dump($_[1]);
+	open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
 	close(OUT);
 	if (open(IN, "peek$$")) {
 	    local $/;
@@ -28,7 +30,7 @@ sub do_test {
 	    print $pattern, "\n" if $DEBUG;
 	    my $dump = <IN>;
 	    print $dump, "\n"    if $DEBUG;
-	    print "not " unless $dump =~ /$pattern/m;
+	    print "[$dump] vs [$pattern]\nnot " unless $dump =~ /$pattern/m;
 	    print "ok $_[0]\n";
 	    close(IN);
 	} else {
@@ -58,7 +60,7 @@ do_test( 2,
         "bar",
 'SV = PV\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(POK,READONLY,pPOK\\)
+  FLAGS = \\(.*POK,READONLY,pPOK\\)
   PV = $ADDR "bar"\\\0
   CUR = 3
   LEN = 4');
@@ -74,7 +76,7 @@ do_test( 4,
         456,
 'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(IOK,READONLY,pIOK\\)
+  FLAGS = \\(.*IOK,READONLY,pIOK\\)
   IV = 456');
 
 do_test( 5,
@@ -108,7 +110,7 @@ do_test( 8,
         0xabcd,
 'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(IOK,READONLY,pIOK,IsUV\\)
+  FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\)
   UV = 43981');
 
 do_test( 9,
@@ -230,9 +232,9 @@ do_test(14,
     DEPTH = 1
     FLAGS = 0x0
     PADLIST = $ADDR
-      1\\. $ADDR \\("\\$pattern" \\d+-\\d+\\)
-     12\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\)
-     13\\. $ADDR \\("\\$dump" \\d+-\\d+\\)
+      \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\)
+     \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\)
+     \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\)
     OUTSIDE = $ADDR \\(MAIN\\)');
 
 do_test(15,
@@ -300,7 +302,7 @@ do_test(17,
     GPFLAGS = 0x0
     LINE = \\d+
     FILE = ".+\\b(?i:peek\\.t)"
-    FLAGS = 0x2
+    FLAGS = $ADDR
     EGV = $ADDR\\t"a"');
 
 END {
diff --git a/t/op/substr.t b/t/op/substr.t
index 5764e67e7a..a67eae56ac 100755
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -1,5 +1,5 @@
 
-print "1..125\n";
+print "1..130\n";
 
 #P = start of string  Q = start of substr  R = end of substr  S = end of string
 
@@ -268,3 +268,16 @@ ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo";
 $a = "abcdefgh";
 ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd';
 ok 125, $a eq 'xxxxefgh';
+
+# utf8 sanity
+{
+    my $x = substr("a\x{263a}b",0);
+    ok 126, length($x) eq 3;
+    $x = substr($x,1,1);
+    ok 127, $x eq "\x{263a}";
+    $x = $x x 2;
+    ok 128, length($x) eq 2;
+    substr($x,0,1) = "abcd";
+    ok 129, $x eq "abcd\x{263a}";
+    ok 130, length($x) eq 5;
+}