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