This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Cleanup File::Copy tests
[perl5.git] / lib / File / Copy.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6 }
7
8 use Test::More;
9
10 my $TB = Test::More->builder;
11
12 plan tests => 46;
13
14 use File::Copy;
15 use Config;
16
17 for (1..2) {
18
19   # First we create a file
20   open(F, ">file-$$") or die;
21   binmode F; # for DOSISH platforms, because test 3 copies to stdout
22   printf F "ok\n";
23   close F;
24
25   copy "file-$$", "copy-$$";
26
27   open(F, "copy-$$") or die;
28   $foo = <F>;
29   close(F);
30
31   is -s "file-$$", -s "copy-$$";
32
33   is $foo, "ok\n";
34
35   binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
36   # This outputs "ok" so its a test.
37   copy "copy-$$", \*STDOUT;
38   $TB->current_test($TB->current_test + 1);
39   unlink "copy-$$" or die "unlink: $!";
40
41   open(F,"file-$$");
42   copy(*F, "copy-$$");
43   open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
44   is $foo, "ok\n";
45   unlink "copy-$$" or die "unlink: $!";
46
47   open(F,"file-$$");
48   copy(\*F, "copy-$$");
49   close(F) or die "close: $!";
50   open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
51   is $foo, "ok\n";
52   unlink "copy-$$" or die "unlink: $!";
53
54   require IO::File;
55   $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
56   binmode $fh or die;
57   copy("file-$$",$fh);
58   $fh->close or die "close: $!";
59   open(R, "copy-$$") or die; $foo = <R>; close(R);
60   is $foo, "ok\n";
61   unlink "copy-$$" or die "unlink: $!";
62
63   require FileHandle;
64   my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
65   binmode $fh or die;
66   copy("file-$$",$fh);
67   $fh->close;
68   open(R, "copy-$$") or die; $foo = <R>; close(R);
69   is $foo, "ok\n";
70   unlink "file-$$" or die "unlink: $!";
71
72   ok !move("file-$$", "copy-$$"), "move on missing file";
73   ok -e "copy-$$",                '  target still there';
74
75   ok move "copy-$$", "file-$$", 'move';
76   ok -e "file-$$",              '  destination exists';
77   ok !-e "copy-$$",              '  source does not';
78   open(R, "file-$$") or die; $foo = <R>; close(R);
79   is $foo, "ok\n";
80
81   copy "file-$$", "lib";
82   open(R, "lib/file-$$") or die; $foo = <R>; close(R);
83   is $foo, "ok\n";
84   unlink "lib/file-$$" or die "unlink: $!";
85
86   # Do it twice to ensure copying over the same file works.
87   copy "file-$$", "lib";
88   open(R, "lib/file-$$") or die; $foo = <R>; close(R);
89   is $foo, "ok\n";
90   unlink "lib/file-$$" or die "unlink: $!";
91
92   eval { copy("file-$$", "file-$$") };
93   like $@, qr/are identical/;
94   ok -s "file-$$";
95
96   move "file-$$", "lib";
97   open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
98   is $foo, "ok\n";
99   ok !-e "file-$$";
100   unlink "lib/file-$$" or die "unlink: $!";
101
102   SKIP: {
103     skip "Testing symlinks", 2 unless $Config{d_symlink};
104
105     open(F, ">file-$$") or die $!;
106     print F "dummy content\n";
107     close F;
108     symlink("file-$$", "symlink-$$") or die $!;
109     eval { copy("file-$$", "symlink-$$") };
110     like $@, qr/are identical/;
111     ok !-z "file-$$", 
112       'rt.perl.org 5196: copying to itself would truncate the file';
113
114     unlink "symlink-$$";
115     unlink "file-$$";
116   }
117
118   SKIP: {
119     skip "Testing hard links", 2 if !$Config{d_link} or $^O eq 'MSWin32';
120
121     open(F, ">file-$$") or die $!;
122     print F "dummy content\n";
123     close F;
124     link("file-$$", "hardlink-$$") or die $!;
125     eval { copy("file-$$", "hardlink-$$") };
126     like $@, qr/are identical/;
127     ok ! -z "file-$$",
128       'rt.perl.org 5196: copying to itself would truncate the file';
129
130     unlink "hardlink-$$";
131     unlink "file-$$";
132   }
133
134 }
135
136
137 END {
138     1 while unlink "file-$$";
139     1 while unlink "lib/file-$$";
140 }