This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The Official 3.2.0 came out.
[perl5.git] / t / io / fs.t
CommitLineData
8d063cd8
LW
1#!./perl
2
ea368a7c
CS
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
0c5d4ba3 6 require "./test.pl";
ea368a7c
CS
7}
8
9use Config;
10
6d738113 11my $Is_VMSish = ($^O eq 'VMS');
0c5d4ba3 12
20dd405c
MS
13if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
14 $wd = `cd`;
15} elsif ($^O eq 'VMS') {
16 $wd = `show default`;
17} else {
18 $wd = `pwd`;
19}
20chomp($wd);
21
0c5d4ba3
JH
22my $has_link = $Config{d_link};
23my $accurate_timestamps =
24 !($^O eq 'MSWin32' || $^O eq 'NetWare' ||
25 $^O eq 'dos' || $^O eq 'os2' ||
20dd405c
MS
26 $^O eq 'mint' || $^O eq 'cygwin' ||
27 $^O eq 'amigaos' || $wd =~ m#$Config{afsroot}/#
28 );
39e571d4 29
6b980173 30if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
0c5d4ba3 31 if (Win32::FsType() eq 'NTFS') {
20dd405c
MS
32 $has_link = 1;
33 $accurate_timestamps = 1;
0c5d4ba3 34 }
6b980173
JD
35}
36
0c5d4ba3
JH
37my $needs_fh_reopen =
38 $^O eq 'dos'
39 # Not needed on HPFS, but needed on HPFS386 ?!
40 || $^O eq 'os2';
41
7a2cf369
NK
42$needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95());
43
4e51f8e4
SR
44my $skip_mode_checks =
45 $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
46
7a2cf369 47plan tests => 36;
8d063cd8 48
378cc40b 49
6d738113
PP
50if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
51 `rmdir /s /q tmp 2>nul`;
52 `mkdir tmp`;
0c5d4ba3 53} elsif ($^O eq 'VMS') {
6d738113
PP
54 `if f\$search("[.tmp]*.*") .nes. "" then delete/nolog/noconfirm [.tmp]*.*.*`;
55 `if f\$search("tmp.dir") .nes. "" then delete/nolog/noconfirm tmp.dir;`;
56 `create/directory [.tmp]`;
57}
58else {
59 `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
60}
0c5d4ba3 61
378cc40b 62chdir './tmp';
0c5d4ba3 63
b8440792 64`/bin/rm -rf a b c x` if -x '/bin/rm';
8d063cd8
LW
65
66umask(022);
67
20dd405c 68SKIP: {
2585f9a3 69 skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc');
20dd405c
MS
70
71 is((umask(0)&0777), 022, 'umask'),
0c5d4ba3
JH
72}
73
8d063cd8
LW
74open(fh,'>x') || die "Can't create x";
75close(fh);
76open(fh,'>a') || die "Can't create a";
77close(fh);
78
8268670f
JH
79my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
80 $blksize,$blocks);
81
3ed9f8f7 82SKIP: {
0c5d4ba3 83 skip("no link", 4) unless $has_link;
8d063cd8 84
0c5d4ba3
JH
85 ok(link('a','b'), "link a b");
86 ok(link('b','c'), "link b c");
8d063cd8 87
8268670f
JH
88 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
89 $blksize,$blocks) = stat('c');
8d063cd8 90
20dd405c
MS
91 SKIP: {
92 skip "no nlink", 1 if $Config{dont_use_nlink};
93
94 is($nlink, 3, "link count of triply-linked file");
0c5d4ba3 95 }
ea368a7c 96
20dd405c
MS
97 SKIP: {
98 skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos';
4e51f8e4 99 skip "no mode checks", 1 if $skip_mode_checks;
20dd405c 100
bbf171ae
GH
101# if ($^O eq 'cygwin') { # new files on cygwin get rwx instead of rw-
102# is($mode & 0777, 0777, "mode of triply-linked file");
103# } else {
4e51f8e4 104 is($mode & 0777, 0666, "mode of triply-linked file");
bbf171ae 105# }
0c5d4ba3
JH
106 }
107}
8d063cd8 108
2986a63f 109$newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777;
8d063cd8 110
0c5d4ba3 111is(chmod($newmode,'a'), 1, "chmod succeeding");
8d063cd8 112
0c5d4ba3 113SKIP: {
2f3b333f 114 skip("no link", 7) unless $has_link;
0c5d4ba3 115
8268670f
JH
116 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
117 $blksize,$blocks) = stat('c');
0c5d4ba3 118
4e51f8e4
SR
119 SKIP: {
120 skip "no mode checks", 1 if $skip_mode_checks;
121
122 is($mode & 0777, $newmode, "chmod going through");
123 }
0c5d4ba3
JH
124
125 $newmode = 0700;
6b980173
JD
126 chmod 0444, 'x';
127 $newmode = 0666;
6b980173 128
0c5d4ba3 129 is(chmod($newmode,'c','x'), 2, "chmod two files");
3ed9f8f7 130
0c5d4ba3
JH
131 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
132 $blksize,$blocks) = stat('c');
8d063cd8 133
4e51f8e4
SR
134 SKIP: {
135 skip "no mode checks", 1 if $skip_mode_checks;
136
137 is($mode & 0777, $newmode, "chmod going through to c");
138 }
a245ea2d 139
0c5d4ba3
JH
140 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
141 $blksize,$blocks) = stat('x');
8d063cd8 142
4e51f8e4
SR
143 SKIP: {
144 skip "no mode checks", 1 if $skip_mode_checks;
145
146 is($mode & 0777, $newmode, "chmod going through to x");
147 }
0c5d4ba3
JH
148
149 is(unlink('b','x'), 2, "unlink two files");
150
151 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
152 $blksize,$blocks) = stat('b');
153
154 is($ino, undef, "ino of removed file b should be undef");
155
156 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
157 $blksize,$blocks) = stat('x');
158
159 is($ino, undef, "ino of removed file x should be undef");
8268670f 160}
0c5d4ba3 161
8268670f 162is(rename('a','b'), 1, "rename a b");
0c5d4ba3 163
8268670f
JH
164($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
165 $blksize,$blocks) = stat('a');
0c5d4ba3 166
8268670f 167is($ino, undef, "ino of renamed file a should be undef");
0c5d4ba3
JH
168
169$delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem
1d825fcc 170chmod 0777, 'b';
a245ea2d 171$foo = (utime 500000000,500000000 + $delta,'b');
0c5d4ba3
JH
172
173is($foo, 1, "utime");
174
8d063cd8
LW
175($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
176 $blksize,$blocks) = stat('b');
0c5d4ba3 177
20dd405c
MS
178SKIP: {
179 skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare');
180
181 ok($ino, 'non-zero inode num');
0c5d4ba3
JH
182}
183
20dd405c 184SKIP: {
3ed9f8f7 185 skip "filesystem atime/mtime granularity too low", 2
20dd405c
MS
186 unless $accurate_timestamps;
187
188 print "# atime - $atime mtime - $mtime delta - $delta\n";
189 if($atime == 500000000 && $mtime == 500000000 + $delta) {
190 pass('atime');
191 pass('mtime');
0c5d4ba3 192 }
20dd405c
MS
193 else {
194 if ($^O =~ /\blinux\b/i) {
195 print "# Maybe stat() cannot get the correct atime, ".
196 "as happens via NFS on linux?\n";
197 $foo = (utime 400000000,500000000 + 2*$delta,'b');
198 my ($new_atime, $new_mtime) = (stat('b'))[8,9];
199 print "# newatime - $new_atime nemtime - $new_mtime\n";
200 if ($new_atime == $atime && $new_mtime - $mtime == $delta) {
3ed9f8f7
NIS
201 pass("atime - accounted for possible NFS/glibc2.2 bug on linux");
202 pass("mtime - accounted for possible NFS/glibc2.2 bug on linux");
203 }
20dd405c 204 else {
3ed9f8f7
NIS
205 fail("atime - $atime/$new_atime $mtime/$new_mtime");
206 fail("mtime - $atime/$new_atime $mtime/$new_mtime");
20dd405c 207 }
3ed9f8f7 208 }
20dd405c
MS
209 elsif ($^O eq 'VMS') {
210 # why is this 1 second off?
211 is( $atime, 500000001, 'atime' );
212 is( $mtime, 500000000 + $delta, 'mtime' );
3ed9f8f7 213 }
20dd405c
MS
214 elsif ($^O eq 'beos') {
215 SKIP: { skip "atime not updated", 1; }
216 is($mtime, 500000001, 'mtime');
3ed9f8f7 217 }
20dd405c
MS
218 else {
219 fail("atime");
220 fail("mtime");
221 }
0c5d4ba3 222 }
6d738113 223}
0c5d4ba3
JH
224
225is(unlink('b'), 1, "unlink b");
226
8d063cd8
LW
227($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
228 $blksize,$blocks) = stat('b');
0c5d4ba3 229is($ino, undef, "ino of unlinked file b should be undef");
378cc40b
LW
230unlink 'c';
231
232chdir $wd || die "Can't cd back to $wd";
233
0c5d4ba3
JH
234# Yet another way to look for links (perhaps those that cannot be
235# created by perl?). Hopefully there is an ls utility in your
236# %PATH%. N.B. that $^O is 'cygwin' on Cygwin.
237
20dd405c
MS
238SKIP: {
239 skip "Win32/Netware specific test", 2
240 unless ($^O eq 'MSWin32') || ($^O eq 'NetWare');
3ed9f8f7 241 skip "No symbolic links found to test with", 2
20dd405c
MS
242 unless `ls -l perl 2>nul` =~ /^l.*->/;
243
4ba7095c
JH
244 system("cp TEST TEST$$");
245 # we have to copy because e.g. GNU grep gets huffy if we have
246 # a symlink forest to another disk (it complains about too many
247 # levels of symbolic links, even if we have only two)
0c5d4ba3 248 is(symlink("TEST$$","c"), 1, "symlink");
4ba7095c 249 $foo = `grep perl c 2>&1`;
0c5d4ba3 250 ok($foo, "found perl in c");
44a8e56a 251 unlink 'c';
4ba7095c 252 unlink("TEST$$");
378cc40b 253}
f783569b 254
f783569b 255unlink "Iofs.tmp";
0c5d4ba3
JH
256open IOFSCOM, ">Iofs.tmp" or die "Could not write IOfs.tmp: $!";
257print IOFSCOM 'helloworld';
258close(IOFSCOM);
259
260# TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP,
261# as per UNIX FAQ.
262
263SKIP: {
264 eval { truncate "Iofs.tmp", 5; };
265
235bddc8 266 skip("no truncate - $@", 6) if $@;
0c5d4ba3
JH
267
268 is(-s "Iofs.tmp", 5, "truncation to five bytes");
269
270 truncate "Iofs.tmp", 0;
271
272 ok(-z "Iofs.tmp", "truncation to zero bytes");
273
7a2cf369
NK
274#these steps are necessary to check if file is really truncated
275#On Win95, FH is updated, but file properties aren't
0c5d4ba3 276 open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
7a2cf369
NK
277 print FH "x\n" x 200;
278 close FH;
279
280
281 open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
0c5d4ba3
JH
282
283 binmode FH;
284 select FH;
285 $| = 1;
286 select STDOUT;
287
288 {
289 use strict;
290 print FH "x\n" x 200;
291 ok(truncate(FH, 200), "fh resize to 200");
62b86938 292 }
0c5d4ba3
JH
293
294 if ($needs_fh_reopen) {
295 close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
296 }
7a2cf369 297
5ca35bcb
PG
298 if ($^O eq 'vos') {
299 is(-s "Iofs.tmp", 200, "TODO - hit VOS bug posix-973 - fh resize to 200 working (filename check)");
300 } else {
301 is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
302 }
0c5d4ba3
JH
303
304 ok(truncate(FH, 0), "fh resize to zero");
305
306 if ($needs_fh_reopen) {
307 close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
308 }
309
7a2cf369
NK
310 ok(-z "Iofs.tmp", "fh resize to zero working (filename check)");
311
312 ok(truncate(FH, 200), "fh resize to 200");
313 is(-s FH, 200, "fh resize to 200 working (FH check)");
0c5d4ba3 314
7a2cf369
NK
315 ok(truncate(FH, 0), "fh resize to 0");
316 ok(-z FH, "fh resize to 0 working (FH check)");
0c5d4ba3 317 close FH;
f783569b 318}
80252599 319
65cb15a1 320# check if rename() can be used to just change case of filename
20dd405c
MS
321SKIP: {
322 skip "Works in Cygwin only if check_case is set to relaxed", 1
323 if $^O eq 'cygwin';
324
0c5d4ba3
JH
325 chdir './tmp';
326 open(fh,'>x') || die "Can't create x";
327 close(fh);
328 rename('x', 'X');
3ed9f8f7 329
0c5d4ba3
JH
330 # this works on win32 only, because fs isn't casesensitive
331 ok(-e 'X', "rename working");
8268670f 332
20dd405c 333 1 while unlink 'X';
0c5d4ba3 334 chdir $wd || die "Can't cd back to $wd";
73077d53 335}
65cb15a1 336
80252599 337# check if rename() works on directories
0c5d4ba3 338if ($^O eq 'VMS') {
9df548ee
CB
339 # must have delete access to rename a directory
340 `set file tmp.dir/protection=o:d`;
20dd405c
MS
341 ok(rename('tmp.dir', 'tmp1.dir'), "rename on directories") ||
342 print "# errno: $!\n";
0c5d4ba3
JH
343} else {
344 ok(rename('tmp', 'tmp1'), "rename on directories");
6d738113 345}
0c5d4ba3
JH
346
347ok(-d 'tmp1', "rename on directories working");
80252599 348
73077d53
GH
349# need to remove 'tmp' if rename() in test 28 failed!
350END { rmdir 'tmp1'; rmdir 'tmp'; unlink "Iofs.tmp"; }