my $TB = Test::More->builder;
-plan tests => 463;
+plan tests => 466;
-# We're going to override rename() later on but Perl has to see an override
+# We are going to override rename() later on but Perl has to see an override
# at compile time to honor it.
BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[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';
local $SIG{__WARN__} = sub { push @warnings, join '', @_ };
# pie-$$ so that we force a non-constant, else the numeric conversion (of 0)
- # is cached and we don't get a warning the second time round
+ # is cached and we do not get a warning the second time round
is eval { copy("file-$$", "copy-$$", "pie-$$"); 1 }, undef,
"a bad buffer size fails to copy";
like $@, qr/Bad buffer size for copy/, "with a helpful error message";
# RT #73714 copy to file with leading whitespace failed
+ TODO: {
+ local $TODO = 'spaces in filenames require DECC$EFS_CHARSET enabled' if $^O eq 'VMS';
open(F, ">file-$$") or die $!;
close F;
copy "file-$$", " copy-$$";
- warn "XXX\n";
ok -e " copy-$$", "copy with leading whitespace";
unlink "file-$$" or die "unlink: $!";
unlink " copy-$$" or die "unlink: $!";
-
+ }
}
+my $can_suidp = sub {
+ my $dir = "suid-$$";
+ my $ok = 1;
+ mkdir $dir or die "Can't mkdir($dir) for suid test";
+ $ok = 0 unless chmod 2000, $dir;
+ rmdir $dir;
+ return $ok;
+};
SKIP: {
my @tests = (
my $skips = @tests * 6 * 8;
- # TODO - make this skip fire if we're on a nosuid filesystem rather than guessing by OS
- skip "OpenBSD filesystems default to nosuid breaking these tests", $skips
- if $^O eq 'openbsd';
+ my $can_suid = $can_suidp->();
+ skip "Can't suid on this $^O filesystem", $skips unless $can_suid;
skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips
if $^O eq 'VMS';
skip "Copy doesn't set file permissions correctly on Win32.", $skips
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 __ ($) {
my $copy4 = "copy4-$$";
my $copy5 = "copy5-$$";
my $copy6 = "copy6-$$";
+ my $copyd = "copyd-$$";
open my $fh => ">", $src or die $!;
close $fh or die $!;
foreach my $test (@tests) {
foreach my $id (0 .. 7) {
my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test;
- # Make sure the copies doesn't exist.
+ # Make sure the copies do not exist.
! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5;
$s_perm |= $id << 9;
# Test that we can actually set a file to the correct permission.
# Slightly convoluted, because some operating systems will let us
# set a directory, but not a file. These should all work:
- mkdir $copy1 or die "Can't mkdir $copy1: $!";
- chmod $s_perm, $copy1
- or die sprintf "Can't chmod %o $copy1: $!", $s_perm;
- rmdir $copy1
- or die sprintf "Can't rmdir $copy1: $!";
+ mkdir $copyd or die "Can't mkdir $copyd: $!";
+ chmod $s_perm, $copyd
+ or die sprintf "Can't chmod %o $copyd: $!", $s_perm;
+ rmdir $copyd
+ or die sprintf "Can't rmdir $copyd: $!";
open my $fh0, '>', $copy1 or die "Can't open $copy1: $!";
close $fh0 or die "Can't close $copy1: $!";
unless (chmod $s_perm, $copy1) {
is (__$perm2, __$permdef, "Permission bits set correctly");
is (__$perm4, __$c_perm1, "Permission bits set correctly");
is (__$perm5, __$c_perm1, "Permission bits set correctly");
- TODO: {
- local $TODO = 'Permission bits inconsistent under cygwin'
- if $^O eq 'cygwin';
- is (__$perm3, __$c_perm3, "Permission bits not modified");
- is (__$perm6, __$c_perm3, "Permission bits not modified");
- }
+ is (__$perm3, __$c_perm3, "Permission bits not modified");
+ is (__$perm6, __$c_perm3, "Permission bits not modified");
}
}
umask $old_mask or die $!;
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';
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;
+}
+
+{
+ open(my $F, '>', "file-$$") or die $!;
+ binmode $F; # for DOSISH platforms
+ printf $F "ok\n";
+ close $F;
+
+ my $buffer = (1024 * 1024 * 2) + 1;
+ is eval {copy "file-$$", "copy-$$", $buffer}, 1,
+ "copy with buffer above normal size";
+}
+
+
END {
+ 1 while unlink "copy-$$";
1 while unlink "file-$$";
1 while unlink "lib/file-$$";
}
https://perl5.git.perl.org / perl5.git / blobdiff