1#!./perl 2 3BEGIN { 4 if( $ENV{PERL_CORE} ) { 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7 } 8} 9 10use Test::More; 11 12my $TB = Test::More->builder; 13 14plan tests => 60; 15 16# We're going to override rename() later on but Perl has to see an override 17# at compile time to honor it. 18BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; } 19 20 21use File::Copy; 22use Config; 23 24 25foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')", 26 "move()", "move('arg')", "move('arg', 'arg', 'arg')" 27 ) 28{ 29 eval $code; 30 like $@, qr/^Usage: /, "'$code' is a usage error"; 31} 32 33 34for my $cross_partition_test (0..1) { 35 { 36 # Simulate a cross-partition copy/move by forcing rename to 37 # fail. 38 no warnings 'redefine'; 39 *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test; 40 } 41 42 # First we create a file 43 open(F, ">file-$$") or die; 44 binmode F; # for DOSISH platforms, because test 3 copies to stdout 45 printf F "ok\n"; 46 close F; 47 48 copy "file-$$", "copy-$$"; 49 50 open(F, "copy-$$") or die; 51 $foo = <F>; 52 close(F); 53 54 is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size'; 55 56 is $foo, "ok\n", 'copy(fn, fn): same contents'; 57 58 print("# next test checks copying to STDOUT\n"); 59 binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode 60 # This outputs "ok" so its a test. 61 copy "copy-$$", \*STDOUT; 62 $TB->current_test($TB->current_test + 1); 63 unlink "copy-$$" or die "unlink: $!"; 64 65 open(F,"file-$$"); 66 copy(*F, "copy-$$"); 67 open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); 68 is $foo, "ok\n", 'copy(*F, fn): same contents'; 69 unlink "copy-$$" or die "unlink: $!"; 70 71 open(F,"file-$$"); 72 copy(\*F, "copy-$$"); 73 close(F) or die "close: $!"; 74 open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; 75 is $foo, "ok\n", 'copy(\*F, fn): same contents'; 76 unlink "copy-$$" or die "unlink: $!"; 77 78 require IO::File; 79 $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; 80 binmode $fh or die; 81 copy("file-$$",$fh); 82 $fh->close or die "close: $!"; 83 open(R, "copy-$$") or die; $foo = <R>; close(R); 84 is $foo, "ok\n", 'copy(fn, io): same contents'; 85 unlink "copy-$$" or die "unlink: $!"; 86 87 require FileHandle; 88 my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; 89 binmode $fh or die; 90 copy("file-$$",$fh); 91 $fh->close; 92 open(R, "copy-$$") or die; $foo = <R>; close(R); 93 is $foo, "ok\n", 'copy(fn, fh): same contents'; 94 unlink "file-$$" or die "unlink: $!"; 95 96 ok !move("file-$$", "copy-$$"), "move on missing file"; 97 ok -e "copy-$$", ' target still there'; 98 99 # Doesn't really matter what time it is as long as its not now. 100 my $time = 1000000000; 101 utime( $time, $time, "copy-$$" ); 102 103 # Recheck the mtime rather than rely on utime in case we're on a 104 # system where utime doesn't work or there's no mtime at all. 105 # The destination file will reflect the same difficulties. 106 my $mtime = (stat("copy-$$"))[9]; 107 108 ok move("copy-$$", "file-$$"), 'move'; 109 ok -e "file-$$", ' destination exists'; 110 ok !-e "copy-$$", ' source does not'; 111 open(R, "file-$$") or die; $foo = <R>; close(R); 112 is $foo, "ok\n", 'contents preserved'; 113 114 TODO: { 115 local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS'; 116 117 my $dest_mtime = (stat("file-$$"))[9]; 118 is $dest_mtime, $mtime, 119 "mtime preserved by copy()". 120 ($cross_partition_test ? " while testing cross-partition" : ""); 121 } 122 123 # trick: create lib/ if not exists - not needed in Perl core 124 unless (-d 'lib') { mkdir 'lib' or die; } 125 copy "file-$$", "lib"; 126 open(R, "lib/file-$$") or die $!; $foo = <R>; close(R); 127 is $foo, "ok\n", 'copy(fn, dir): same contents'; 128 unlink "lib/file-$$" or die "unlink: $!"; 129 130 # Do it twice to ensure copying over the same file works. 131 copy "file-$$", "lib"; 132 open(R, "lib/file-$$") or die; $foo = <R>; close(R); 133 is $foo, "ok\n", 'copy over the same file works'; 134 unlink "lib/file-$$" or die "unlink: $!"; 135 136 { 137 my $warnings = ''; 138 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 139 ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds'; 140 141 like $warnings, qr/are identical/, 'but warns'; 142 ok -s "file-$$", 'contents preserved'; 143 } 144 145 move "file-$$", "lib"; 146 open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); 147 is $foo, "ok\n", 'move(fn, dir): same contents'; 148 ok !-e "file-$$", 'file moved indeed'; 149 unlink "lib/file-$$" or die "unlink: $!"; 150 151 SKIP: { 152 skip "Testing symlinks", 3 unless $Config{d_symlink}; 153 154 open(F, ">file-$$") or die $!; 155 print F "dummy content\n"; 156 close F; 157 symlink("file-$$", "symlink-$$") or die $!; 158 159 my $warnings = ''; 160 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 161 ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails'; 162 163 like $warnings, qr/are identical/, 'emits a warning'; 164 ok !-z "file-$$", 165 'rt.perl.org 5196: copying to itself would truncate the file'; 166 167 unlink "symlink-$$"; 168 unlink "file-$$"; 169 } 170 171 SKIP: { 172 skip "Testing hard links", 3 173 if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; 174 175 open(F, ">file-$$") or die $!; 176 print F "dummy content\n"; 177 close F; 178 link("file-$$", "hardlink-$$") or die $!; 179 180 my $warnings = ''; 181 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 182 ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails'; 183 184 like $warnings, qr/are identical/, 'emits a warning'; 185 ok ! -z "file-$$", 186 'rt.perl.org 5196: copying to itself would truncate the file'; 187 188 unlink "hardlink-$$"; 189 unlink "file-$$"; 190 } 191} 192 193 194END { 195 1 while unlink "file-$$"; 196 1 while unlink "lib/file-$$"; 197} 198