Import perl-5.18.2

OK espie@ sthen@ deraadt@

6 files changed, 262 insertions, 101 deletions

diff --git a/gnu/usr.bin/perl/lib/File/Basename.t b/gnu/usr.bin/perl/lib/File/Basename.t
index 0d3b633669d..6ff3121ec93 100644
--- a/gnu/usr.bin/perl/lib/File/Basename.t
+++ b/gnu/usr.bin/perl/lib/File/Basename.t
@@ -154,7 +154,9 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
 
 
 ### Test tainting
-{
+SKIP: {
+    skip "A perl without taint support", 2
+        if not ${^TAINT};
     #   The empty tainted value, for tainting strings
     my $TAINT = substr($^X, 0, 0);
 
diff --git a/gnu/usr.bin/perl/lib/File/Copy.t b/gnu/usr.bin/perl/lib/File/Copy.t
index ffd3d59db78..1e6c9cb4a12 100644
--- a/gnu/usr.bin/perl/lib/File/Copy.t
+++ b/gnu/usr.bin/perl/lib/File/Copy.t
@@ -14,7 +14,7 @@ use Test::More;
 
 my $TB = Test::More->builder;
 
-plan tests => 463;
+plan tests => 465;
 
 # We're going to override rename() later on but Perl has to see an override
 # at compile time to honor it.
@@ -139,7 +139,7 @@ for my $cross_partition_test (0..1) {
   { 
     my $warnings = '';
     local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
-    ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds';
+    ok !copy("file-$$", "file-$$"), 'copy to itself fails';
 
     like $warnings, qr/are identical/, 'but warns';
     ok -s "file-$$", 'contents preserved';
@@ -267,6 +267,9 @@ SKIP: {
           if $^O eq "MSWin32";
     skip "Copy maps POSIX permissions to VOS permissions.", $skips
           if $^O eq "vos";
+    skip "There be dragons here with DragonflyBSD.", $skips
+         if $^O eq 'dragonfly';
+
 
     # Just a sub to get better failure messages.
     sub __ ($) {
@@ -411,7 +414,7 @@ SKIP: {
 	foreach my $right (qw(plain object1 object2)) {
 	    @warnings = ();
 	    $! = 0;
-	    is eval {copy $what{$left}, $what{$right}}, 1, "copy $left $right";
+	    is eval {copy $what{$left}, $what{$right}}, 0, "copy $left $right";
 	    is $@, '', 'No croaking';
 	    is $!, '', 'No system call errors';
 	    is @warnings, 1, 'Exactly 1 warning';
@@ -472,6 +475,31 @@ SKIP: {
     close($IN);
 }
 
+use File::Temp qw(tempdir);
+use File::Spec;
+
+SKIP: {
+    # RT #111126: File::Copy copy() zeros file when copying a file
+    # into the same directory it is stored in
+
+    my $temp_dir = tempdir( CLEANUP => 1 );
+    my $temp_file = File::Spec->catfile($temp_dir, "somefile");
+
+    open my $fh, ">", $temp_file
+	or skip "Cannot create $temp_file: $!", 2;
+    print $fh "Just some data";
+    close $fh
+	or skip "Cannot close $temp_file: $!", 2;
+
+    my $warn_message = "";
+    local $SIG{__WARN__} = sub { $warn_message .= "@_" };
+    ok(!copy($temp_file, $temp_dir),
+       "Copy of foo/file to foo/ should fail");
+    like($warn_message, qr/^\Q'$temp_file' and '$temp_file'\E are identical.*Copy\.t/i,
+	 "error message should describe the problem");
+    1 while unlink $temp_file;
+}
+
 END {
     1 while unlink "file-$$";
     1 while unlink "lib/file-$$";
diff --git a/gnu/usr.bin/perl/lib/File/Find/t/find.t b/gnu/usr.bin/perl/lib/File/Find/t/find.t
index 1d0a0870b13..96a10005114 100644
--- a/gnu/usr.bin/perl/lib/File/Find/t/find.t
+++ b/gnu/usr.bin/perl/lib/File/Find/t/find.t
@@ -18,7 +18,7 @@ BEGIN {
     $SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# $_[0]"; }
 }
 
-my $test_count = 85;
+my $test_count = 98;
 $test_count += 119 if $symlink_exists;
 $test_count += 26 if $^O eq 'MSWin32';
 $test_count += 2 if $^O eq 'MSWin32' and $symlink_exists;
@@ -108,6 +108,21 @@ sub cleanup {
 	rmdir dir_path('fb', 'fbc');
 	rmdir dir_path('fb');
     }
+    if (-d dir_path('fc')) {
+        unlink (
+            file_path('fc', 'fca', 'match_alpha'),
+            file_path('fc', 'fca', 'match_beta'),
+            file_path('fc', 'fcb', 'match_gamma'),
+            file_path('fc', 'fcb', 'delta'),
+            file_path('fc', 'fcc', 'match_epsilon'),
+            file_path('fc', 'fcc', 'match_zeta'),
+            file_path('fc', 'fcc', 'eta'),
+        );
+        rmdir dir_path('fc', 'fca');
+        rmdir dir_path('fc', 'fcb');
+        rmdir dir_path('fc', 'fcc');
+        rmdir dir_path('fc');
+    }
     if ($need_updir) {
         my $updir = $^O eq 'VMS' ? File::Spec::VMS->updir() : File::Spec->updir;
         chdir($updir);
@@ -197,7 +212,7 @@ sub my_preprocess {
     print "# --preprocess--\n";
     print "#   \$File::Find::dir => '$File::Find::dir' \n";
     foreach $file (@files) {
-        $file =~ s/\.(dir)?$// if $^O eq 'VMS';
+        $file =~ s/\.(dir)?$//i if $^O eq 'VMS';
         print "#   $file \n";
         delete $Expect_Dir{ $File::Find::dir }->{$file};
     }
@@ -870,6 +885,41 @@ if ($symlink_exists) {  # Issue 68260
     Check (!$dangling_symlink);
 }
 
+print "# RT 59750\n";
+MkDir( dir_path('fc'), 0770 );
+MkDir( dir_path('fc', 'fca'), 0770 );
+MkDir( dir_path('fc', 'fcb'), 0770 );
+MkDir( dir_path('fc', 'fcc'), 0770 );
+touch( file_path('fc', 'fca', 'match_alpha') );
+touch( file_path('fc', 'fca', 'match_beta') );
+touch( file_path('fc', 'fcb', 'match_gamma') );
+touch( file_path('fc', 'fcb', 'delta') );
+touch( file_path('fc', 'fcc', 'match_epsilon') );
+touch( file_path('fc', 'fcc', 'match_zeta') );
+touch( file_path('fc', 'fcc', 'eta') );
+
+my @files_from_mixed = ();
+sub wantmatch {
+    if ( $File::Find::name =~ m/match/ ) {
+        push @files_from_mixed, $_;
+        print "# \$_ => '$_'\n";
+    }
+}
+find( \&wantmatch, (
+    dir_path('fc', 'fca'),
+    dir_path('fc', 'fcb'),
+    dir_path('fc', 'fcc'),
+) );
+Check( scalar(@files_from_mixed) == 5 );
+
+@files_from_mixed = ();
+find( \&wantmatch, (
+    dir_path('fc', 'fca'),
+    dir_path('fc', 'fcb'),
+    file_path('fc', 'fcc', 'match_epsilon'),
+    file_path('fc', 'fcc', 'eta'),
+) );
+Check( scalar(@files_from_mixed) == 4 );
 
 if ($^O eq 'MSWin32') {
     # Check F:F:f correctly handles a root directory path.
diff --git a/gnu/usr.bin/perl/lib/File/Find/t/taint.t b/gnu/usr.bin/perl/lib/File/Find/t/taint.t
index d47b21a7c31..954c6780d94 100644
--- a/gnu/usr.bin/perl/lib/File/Find/t/taint.t
+++ b/gnu/usr.bin/perl/lib/File/Find/t/taint.t
@@ -1,12 +1,19 @@
 #!./perl -T
 use strict;
+use Test::More;
+BEGIN {
+    plan(
+        ${^TAINT}
+        ? (tests => 45)
+        : (skip_all => "A perl without taint support") 
+    );
+}
 
 my %Expect_File = (); # what we expect for $_
 my %Expect_Name = (); # what we expect for $File::Find::name/fullname
 my %Expect_Dir  = (); # what we expect for $File::Find::dir
 my ($cwd, $cwd_untainted);
 
-
 BEGIN {
     require File::Spec;
     chdir 't' if -d 't';
@@ -42,8 +49,6 @@ BEGIN {
     $ENV{'PATH'} = join($sep,@path);
 }
 
-use Test::More tests => 45;
-
 my $symlink_exists = eval { symlink("",""); 1 };
 
 use File::Find;
diff --git a/gnu/usr.bin/perl/lib/File/stat-7896.t b/gnu/usr.bin/perl/lib/File/stat-7896.t
new file mode 100644
index 00000000000..57b26858520
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/File/stat-7896.t
@@ -0,0 +1,28 @@
+#!./perl -w
+use strict;
+
+use Test::More;
+use File::stat;
+
+# This is possibly a bit black-box, but for now it works.
+# If (either) File::stat stops lazy loading Symbol, or Test::More starts, it
+# should be revisited
+is($INC{'Symbol.pm'}, undef, "Symbol isn't loaded yet");
+
+# ID 20011110.104 (RT #7896)
+$! = 0;
+is($!, '', '$! is empty');
+is(File::stat::stat('/notafile'), undef, 'invalid file should fail');
+isnt($!, '', 'should populate $!, given invalid file');
+my $e = $!;
+
+isnt($INC{'Symbol.pm'}, undef, "Symbol has been loaded");
+
+# Repeat twice
+is(File::stat::stat('/notafile'), undef, 'invalid file should fail again');
+is($!, $e, '$! should be consistent for an invalid file');
+$e = $!;
+is(File::stat::stat('/notafile'), undef, 'invalid file should fail again');
+is($!, $e, '$! should be consistent for an invalid file');
+
+done_testing();
diff --git a/gnu/usr.bin/perl/lib/File/stat.t b/gnu/usr.bin/perl/lib/File/stat.t
index 0646ebdcd6f..b85ff95462c 100644
--- a/gnu/usr.bin/perl/lib/File/stat.t
+++ b/gnu/usr.bin/perl/lib/File/stat.t
@@ -5,107 +5,136 @@ BEGIN {
     @INC = '../lib';
 }
 
+use strict;
+use warnings;
 use Test::More;
 use Config qw( %Config );
-
-BEGIN {
-    # Check whether the build is configured with -Dmksymlinks
-    our $Dmksymlinks =
-        grep { /^config_arg\d+$/ && $Config{$_} eq '-Dmksymlinks' }
-        keys %Config;
-
-    # Resolve symlink to ./lib/File/stat.t if this build is configured
-    # with -Dmksymlinks
-    # Originally we worked with ./TEST, but other test scripts read from
-    # that file and modify its access time.
-    our $file = '../lib/File/stat.t';
-    if ( $Dmksymlinks ) {
-        $file = readlink $file;
-        die "Can't readlink(../lib/File/stat.t): $!" if ! defined $file;
+use File::Temp qw( tempfile tempdir );
+
+use File::stat;
+
+my (undef, $file) = tempfile();
+
+{
+    my @stat = CORE::stat $file;
+    my $stat = File::stat::stat($file);
+    isa_ok($stat, 'File::stat', 'should build a stat object');
+    is_deeply($stat, \@stat, '... and matches the builtin');
+
+    my $i = 0;
+    foreach ([dev => 'device number'],
+             [ino => 'inode number'],
+             [mode => 'file mode'],
+             [nlink => 'number of links'],
+             [uid => 'owner uid'],
+             [gid => 'group id'],
+             [rdev => 'device identifier'],
+             [size => 'file size'],
+             [atime => 'last access time'],
+             [mtime => 'last modify time'],
+             [ctime => 'change time'],
+             [blksize => 'IO block size'],
+             [blocks => 'number of blocks']) {
+        my ($meth, $desc) = @$_;
+        # On OS/2 (fake) ino is not constant, it is incremented each time
+    SKIP: {
+            skip('inode number is not constant on OS/2', 1)
+                if $i == 1 && $^O eq 'os2';
+            is($stat->$meth, $stat[$i], "$desc in position $i");
+        }
+        ++$i;
     }
 
-    our $hasst;
-    eval { my @n = stat $file };
-    $hasst = 1 unless $@ && $@ =~ /unimplemented/;
-    unless ($hasst) { plan skip_all => "no stat"; exit 0 }
-    use Config;
-    $hasst = 0 unless $Config{'i_sysstat'} eq 'define';
-    unless ($hasst) { plan skip_all => "no sys/stat.h"; exit 0 }
+    my $stat2 = stat $file;
+    isa_ok($stat2, 'File::stat',
+           'File::stat exports stat, overriding the builtin');
+    is_deeply($stat2, $stat, '... and matches the direct call');
 }
 
-# Originally this was done in the BEGIN block, but perl is still
-# compiling (and hence reading) the script at that point, which can
-# change the file's access time, causing a different in the comparison
-# tests if the clock ticked over the second between the stat() and the
-# final read.
-# At this point all of the reading is done.
-our @stat = stat $file; # This is the function stat.
-unless (@stat) { plan skip_all => "1..0 # Skip: no file $file"; exit 0 }
-
-plan tests => 19 + 24*2 + 4 + 3;
-
-use_ok( 'File::stat' );
-
-my $stat = File::stat::stat( $file ); # This is the OO stat.
-ok( ref($stat), 'should build a stat object' );
-
-is( $stat->dev, $stat[0], "device number in position 0" );
-
-# On OS/2 (fake) ino is not constant, it is incremented each time
-SKIP: {
-	skip('inode number is not constant on OS/2', 1) if $^O eq 'os2';
-	is( $stat->ino, $stat[1], "inode number in position 1" );
+sub test_X_ops {
+    my ($file, $desc_tail, $skip) = @_;
+    my @stat = CORE::stat $file;
+    my $stat = File::stat::stat($file);
+    my $lstat = File::stat::lstat($file);
+    isa_ok($stat, 'File::stat', 'should build a stat object');
+
+    for my $op (split //, "rwxoRWXOezsfdlpSbcugkMCA") {
+        if ($skip && $op =~ $skip) {
+            note("Not testing -A $desc_tail");
+            next;
+        }
+        my $stat = $op eq 'l' ? $lstat : $stat;
+        for my $access ('', 'use filetest "access";') {
+            my ($warnings, $awarn, $vwarn, $rv);
+            my $desc = $access
+                ? "for -$op under use filetest 'access' $desc_tail"
+                    : "for -$op $desc_tail";
+            {
+                local $SIG{__WARN__} = sub {
+                    my $w = shift;
+                    if ($w =~ /^File::stat ignores VMS ACLs/) {
+                        ++$vwarn;
+                    } elsif ($w =~ /^File::stat ignores use filetest 'access'/) {
+                        ++$awarn;
+                    } else {
+                        $warnings .= $w;
+                    }
+                };
+                $rv = eval "$access; -$op \$stat";
+            }
+            is($@, '', "Overload succeeds $desc");
+
+            if ($^O eq "VMS" && $op =~ /[rwxRWX]/) {
+                is($vwarn, 1, "warning about VMS ACLs $desc");
+            } else {
+                is($rv, eval "-$op \$file", "correct overload $desc")
+                    unless $access;
+                is($vwarn, undef, "no warnings about VMS ACLs $desc");
+            }
+
+            # 111640 - File::stat bogus index check in overload
+            if ($access && $op =~ /[rwxRXW]/) {
+                # these should all warn with filetest access
+                is($awarn, 1,
+                   "produced the right warning $desc");
+            } else {
+                # -d and others shouldn't warn
+                is($awarn, undef, "should be no warning $desc")
+            }
+
+            is($warnings, undef, "no other warnings seen $desc");
+        }
+    }
 }
 
-is( $stat->mode, $stat[2], "file mode in position 2" );
-
-is( $stat->nlink, $stat[3], "number of links in position 3" );
-
-is( $stat->uid, $stat[4], "owner uid in position 4" );
-
-is( $stat->gid, $stat[5], "group id in position 5" );
-
-is( $stat->rdev, $stat[6], "device identifier in position 6" );
-
-is( $stat->size, $stat[7], "file size in position 7" );
-
-is( $stat->atime, $stat[8], "last access time in position 8" );
-
-is( $stat->mtime, $stat[9], "last modify time in position 9" );
-
-is( $stat->ctime, $stat[10], "change time in position 10" );
-
-is( $stat->blksize, $stat[11], "IO block size in position 11" );
-
-is( $stat->blocks, $stat[12], "number of blocks in position 12" );
-
-for (split //, "rwxoRWXOezsfdlpSbcugkMCA") {
-    SKIP: {
-        $^O eq "VMS" and index("rwxRWX", $_) >= 0
-            and skip "File::stat ignores VMS ACLs", 2;
-
-        my $rv = eval "-$_ \$stat";
-        ok( !$@,                            "-$_ overload succeeds" )
-            or diag( $@ );
-        is( $rv, eval "-$_ \$file",         "correct -$_ overload" );
+foreach ([file => $file],
+         [dir => tempdir(CLEANUP => 1)]) {
+    my ($what, $pathname) = @$_;
+    test_X_ops($pathname, "for $what $pathname");
+
+    my $mode = 01000;
+    while ($mode) {
+        $mode >>= 1;
+        my $mode_oct = sprintf "0%03o", $mode;
+        chmod $mode, $pathname or die "Can't chmod $mode_oct $pathname: $!";
+        test_X_ops($pathname, "for $what with mode=$mode_oct");
     }
+    chmod 0600, $pathname
+        or die "Can't restore permissions on $pathname to 0600";
 }
 
 SKIP: {
-    my $file = '../perl';
-    -e $file && -x $file or skip "$file is not present and executable", 4;
+    -e $^X && -x $^X or skip "$^X is not present and executable", 4;
     $^O eq "VMS" and skip "File::stat ignores VMS ACLs", 4;
 
-    my $stat = File::stat::stat( $file ); # This is the OO stat.
-    foreach (qw/x X/) {
-    my $rv = eval "-$_ \$stat";
-    ok( !$@,                            "-$_ overload succeeds" )
-      or diag( $@ );
-    is( $rv, eval "-$_ \$file",         "correct -$_ overload" );
-  }
+    # Other tests running in parallel mean that $^X is read, updating its atime
+    test_X_ops($^X, "for $^X", qr/A/);
 }
 
 
+my $stat = File::stat::stat($file);
+isa_ok($stat, 'File::stat', 'should build a stat object');
+
 for (split //, "tTB") {
     eval "-$_ \$stat";
     like( $@, qr/\Q-$_ is not implemented/, "-$_ overload fails" );
@@ -114,12 +143,14 @@ for (split //, "tTB") {
 SKIP: {
 	local *STAT;
 	skip("Could not open file: $!", 2) unless open(STAT, $file);
-	ok( File::stat::stat('STAT'), '... should be able to find filehandle' );
+	isa_ok(File::stat::stat('STAT'), 'File::stat',
+	       '... should be able to find filehandle');
 
 	package foo;
 	local *STAT = *main::STAT;
-	main::ok( my $stat2 = File::stat::stat('STAT'), 
-		'... and filehandle in another package' );
+	my $stat2 = File::stat::stat('STAT');
+	main::isa_ok($stat2, 'File::stat',
+		     '... and filehandle in another package');
 	close STAT;
 
 #	VOS open() updates atime; ignore this error (posix-975).
@@ -133,12 +164,29 @@ SKIP: {
 
 	main::skip("OS/2: inode number is not constant on os/2", 1) if $^O eq 'os2';
 
-	main::is( "@$stat", "@$stat3", '... and must match normal stat' );
+	main::is_deeply($stat, $stat3, '... and must match normal stat');
 }
 
-
-local $!;
-$stat = stat '/notafile';
-isnt( $!, '', 'should populate $!, given invalid file' );
+SKIP:
+{   # RT #111638
+    skip "We can't check for FIFOs", 2 unless defined &Fcntl::S_ISFIFO;
+    skip "No pipes", 2 unless defined $Config{d_pipe};
+    pipe my ($rh, $wh)
+      or skip "Couldn't create a pipe: $!", 2;
+    skip "Built-in -p doesn't detect a pipe", 2 unless -p $rh;
+
+    my $pstat = File::stat::stat($rh);
+    ok(!-p($stat), "-p should be false on a file");
+    ok(-p($pstat), "check -p detects a pipe");
+}
 
 # Testing pretty much anything else is unportable.
+
+done_testing;
+
+# Local variables:
+# cperl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
+#
+# ex: set ts=8 sts=4 sw=4 et: