Move the require './test.pl' to the end of t/comp/hints.t
[p5sagit/p5-mst-13.2.git] / t / io / fs.t
CommitLineData
8d063cd8 1#!./perl
2
ea368a7c 3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
0c5d4ba3 6 require "./test.pl";
ea368a7c 7}
8
9use Config;
dc459aad 10use File::Spec::Functions;
ea368a7c 11
6d738113 12my $Is_VMSish = ($^O eq 'VMS');
0c5d4ba3 13
20dd405c 14if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
15 $wd = `cd`;
fc8d54b0 16}
17elsif ($^O eq 'VMS') {
20dd405c 18 $wd = `show default`;
fc8d54b0 19}
20else {
20dd405c 21 $wd = `pwd`;
22}
23chomp($wd);
24
0c5d4ba3 25my $has_link = $Config{d_link};
26my $accurate_timestamps =
27 !($^O eq 'MSWin32' || $^O eq 'NetWare' ||
28 $^O eq 'dos' || $^O eq 'os2' ||
cd86ed9d 29 $^O eq 'cygwin' || $^O eq 'amigaos' ||
7b903762 30 $wd =~ m#$Config{afsroot}/#
20dd405c 31 );
39e571d4 32
6b980173 33if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
0c5d4ba3 34 if (Win32::FsType() eq 'NTFS') {
20dd405c 35 $has_link = 1;
36 $accurate_timestamps = 1;
0c5d4ba3 37 }
6b980173 38}
39
0c5d4ba3 40my $needs_fh_reopen =
41 $^O eq 'dos'
42 # Not needed on HPFS, but needed on HPFS386 ?!
43 || $^O eq 'os2';
44
7a2cf369 45$needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95());
46
4e51f8e4 47my $skip_mode_checks =
48 $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
49
1937c63e 50plan tests => 51;
8d063cd8 51
62a28c97 52my $tmpdir = tempfile();
53my $tmpdir1 = tempfile();
378cc40b 54
6d738113 55if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
62a28c97 56 `rmdir /s /q $tmpdir 2>nul`;
57 `mkdir $tmpdir`;
dc459aad 58}
59elsif ($^O eq 'VMS') {
62a28c97 60 `if f\$search("[.$tmpdir]*.*") .nes. "" then delete/nolog/noconfirm [.$tmpdir]*.*.*`;
61 `if f\$search("$tmpdir.dir") .nes. "" then set file/prot=o:rwed $tmpdir.dir;`;
62 `if f\$search("$tmpdir.dir") .nes. "" then delete/nolog/noconfirm $tmpdir.dir;`;
63 `create/directory [.$tmpdir]`;
6d738113 64}
65else {
62a28c97 66 `rm -f $tmpdir 2>/dev/null; mkdir $tmpdir 2>/dev/null`;
6d738113 67}
0c5d4ba3 68
62a28c97 69chdir catdir(curdir(), $tmpdir);
0c5d4ba3 70
b8440792 71`/bin/rm -rf a b c x` if -x '/bin/rm';
8d063cd8 72
73umask(022);
74
20dd405c 75SKIP: {
7b903762 76 skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc');
20dd405c 77
78 is((umask(0)&0777), 022, 'umask'),
0c5d4ba3 79}
80
d5fc3e70 81open(FH,'>x') || die "Can't create x";
82close(FH);
83open(FH,'>a') || die "Can't create a";
84close(FH);
8d063cd8 85
8268670f 86my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
dd568cb6 87 $blksize,$blocks,$a_mode);
8268670f 88
3ed9f8f7 89SKIP: {
0c5d4ba3 90 skip("no link", 4) unless $has_link;
8d063cd8 91
0c5d4ba3 92 ok(link('a','b'), "link a b");
93 ok(link('b','c'), "link b c");
8d063cd8 94
dd568cb6 95 $a_mode = (stat('a'))[2];
96
8268670f 97 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
98 $blksize,$blocks) = stat('c');
8d063cd8 99
20dd405c 100 SKIP: {
101 skip "no nlink", 1 if $Config{dont_use_nlink};
102
103 is($nlink, 3, "link count of triply-linked file");
0c5d4ba3 104 }
ea368a7c 105
20dd405c 106 SKIP: {
107 skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos';
4e51f8e4 108 skip "no mode checks", 1 if $skip_mode_checks;
20dd405c 109
bbf171ae 110# if ($^O eq 'cygwin') { # new files on cygwin get rwx instead of rw-
111# is($mode & 0777, 0777, "mode of triply-linked file");
112# } else {
dd568cb6 113 is(sprintf("0%o", $mode & 0777),
114 sprintf("0%o", $a_mode & 0777),
115 "mode of triply-linked file");
bbf171ae 116# }
0c5d4ba3 117 }
118}
8d063cd8 119
2986a63f 120$newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777;
8d063cd8 121
0c5d4ba3 122is(chmod($newmode,'a'), 1, "chmod succeeding");
8d063cd8 123
0c5d4ba3 124SKIP: {
2f3b333f 125 skip("no link", 7) unless $has_link;
0c5d4ba3 126
8268670f 127 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
128 $blksize,$blocks) = stat('c');
0c5d4ba3 129
4e51f8e4 130 SKIP: {
131 skip "no mode checks", 1 if $skip_mode_checks;
132
133 is($mode & 0777, $newmode, "chmod going through");
134 }
0c5d4ba3 135
136 $newmode = 0700;
6b980173 137 chmod 0444, 'x';
138 $newmode = 0666;
6b980173 139
0c5d4ba3 140 is(chmod($newmode,'c','x'), 2, "chmod two files");
3ed9f8f7 141
0c5d4ba3 142 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
143 $blksize,$blocks) = stat('c');
8d063cd8 144
4e51f8e4 145 SKIP: {
146 skip "no mode checks", 1 if $skip_mode_checks;
147
148 is($mode & 0777, $newmode, "chmod going through to c");
149 }
a245ea2d 150
0c5d4ba3 151 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
152 $blksize,$blocks) = stat('x');
8d063cd8 153
4e51f8e4 154 SKIP: {
155 skip "no mode checks", 1 if $skip_mode_checks;
156
157 is($mode & 0777, $newmode, "chmod going through to x");
158 }
0c5d4ba3 159
160 is(unlink('b','x'), 2, "unlink two files");
161
162 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
163 $blksize,$blocks) = stat('b');
164
165 is($ino, undef, "ino of removed file b should be undef");
166
167 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
168 $blksize,$blocks) = stat('x');
169
170 is($ino, undef, "ino of removed file x should be undef");
8268670f 171}
0c5d4ba3 172
c4aca7d0 173SKIP: {
174 skip "no fchmod", 5 unless ($Config{d_fchmod} || "") eq "define";
175 ok(open(my $fh, "<", "a"), "open a");
176 is(chmod(0, $fh), 1, "fchmod");
177 $mode = (stat "a")[2];
b0fdffbd 178 SKIP: {
179 skip "no mode checks", 1 if $skip_mode_checks;
180 is($mode & 0777, 0, "perm reset");
181 }
c4aca7d0 182 is(chmod($newmode, "a"), 1, "fchmod");
183 $mode = (stat $fh)[2];
b0fdffbd 184 SKIP: {
185 skip "no mode checks", 1 if $skip_mode_checks;
186 is($mode & 0777, $newmode, "perm restored");
187 }
c4aca7d0 188}
189
190SKIP: {
191 skip "no fchown", 1 unless ($Config{d_fchown} || "") eq "define";
192 open(my $fh, "<", "a");
193 is(chown(-1, -1, $fh), 1, "fchown");
194}
195
196SKIP: {
197 skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define";
198 open(my $fh, "<", "a");
199 eval { chmod(0777, $fh); };
200 like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented");
201}
202
203SKIP: {
204 skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define";
205 open(my $fh, "<", "a");
206 eval { chown(0, 0, $fh); };
295d5f02 207 like($@, qr/^The f?chown function is unimplemented at/, "fchown is unimplemented");
c4aca7d0 208}
209
8268670f 210is(rename('a','b'), 1, "rename a b");
0c5d4ba3 211
8268670f 212($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
213 $blksize,$blocks) = stat('a');
0c5d4ba3 214
8268670f 215is($ino, undef, "ino of renamed file a should be undef");
0c5d4ba3 216
217$delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem
1d825fcc 218chmod 0777, 'b';
0c5d4ba3 219
e96b369d 220$foo = (utime 500000000,500000000 + $delta,'b');
0c5d4ba3 221is($foo, 1, "utime");
e96b369d 222check_utime_result();
223
224utime undef, undef, 'b';
225($atime,$mtime) = (stat 'b')[8,9];
226print "# utime undef, undef --> $atime, $mtime\n";
227isnt($atime, 500000000, 'atime');
228isnt($mtime, 500000000 + $delta, 'mtime');
229
230SKIP: {
231 skip "no futimes", 4 unless ($Config{d_futimes} || "") eq "define";
232 open(my $fh, "<", 'b');
233 $foo = (utime 500000000,500000000 + $delta, $fh);
234 is($foo, 1, "futime");
235 check_utime_result();
236}
0c5d4ba3 237
e96b369d 238
239sub check_utime_result {
fc8d54b0 240 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
241 $blksize,$blocks) = stat('b');
0c5d4ba3 242
fc8d54b0 243 SKIP: {
244 skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare');
20dd405c 245
fc8d54b0 246 ok($ino, 'non-zero inode num');
247 }
0c5d4ba3 248
fc8d54b0 249 SKIP: {
250 skip "filesystem atime/mtime granularity too low", 2
251 unless $accurate_timestamps;
20dd405c 252
fc8d54b0 253 print "# atime - $atime mtime - $mtime delta - $delta\n";
254 if($atime == 500000000 && $mtime == 500000000 + $delta) {
255 pass('atime');
256 pass('mtime');
257 }
258 else {
259 if ($^O =~ /\blinux\b/i) {
260 print "# Maybe stat() cannot get the correct atime, ".
261 "as happens via NFS on linux?\n";
262 $foo = (utime 400000000,500000000 + 2*$delta,'b');
263 my ($new_atime, $new_mtime) = (stat('b'))[8,9];
264 print "# newatime - $new_atime nemtime - $new_mtime\n";
265 if ($new_atime == $atime && $new_mtime - $mtime == $delta) {
266 pass("atime - accounted for possible NFS/glibc2.2 bug on linux");
267 pass("mtime - accounted for possible NFS/glibc2.2 bug on linux");
268 }
269 else {
270 fail("atime - $atime/$new_atime $mtime/$new_mtime");
271 fail("mtime - $atime/$new_atime $mtime/$new_mtime");
272 }
273 }
274 elsif ($^O eq 'VMS') {
275 # why is this 1 second off?
276 is( $atime, 500000001, 'atime' );
277 is( $mtime, 500000000 + $delta, 'mtime' );
278 }
df00ff3b 279 elsif ($^O eq 'beos' || $^O eq 'haiku') {
fc8d54b0 280 SKIP: {
281 skip "atime not updated", 1;
282 }
283 is($mtime, 500000001, 'mtime');
284 }
285 else {
286 fail("atime");
287 fail("mtime");
288 }
289 }
0c5d4ba3 290 }
6d738113 291}
e96b369d 292
293SKIP: {
294 skip "has futimes", 1 if ($Config{d_futimes} || "") eq "define";
295 open(my $fh, "<", "b") || die;
296 eval { utime(undef, undef, $fh); };
297 like($@, qr/^The futimes function is unimplemented at/, "futimes is unimplemented");
298}
0c5d4ba3 299
300is(unlink('b'), 1, "unlink b");
301
8d063cd8 302($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
303 $blksize,$blocks) = stat('b');
0c5d4ba3 304is($ino, undef, "ino of unlinked file b should be undef");
378cc40b 305unlink 'c';
306
307chdir $wd || die "Can't cd back to $wd";
308
0c5d4ba3 309# Yet another way to look for links (perhaps those that cannot be
310# created by perl?). Hopefully there is an ls utility in your
311# %PATH%. N.B. that $^O is 'cygwin' on Cygwin.
312
20dd405c 313SKIP: {
314 skip "Win32/Netware specific test", 2
315 unless ($^O eq 'MSWin32') || ($^O eq 'NetWare');
3ed9f8f7 316 skip "No symbolic links found to test with", 2
20dd405c 317 unless `ls -l perl 2>nul` =~ /^l.*->/;
318
4ba7095c 319 system("cp TEST TEST$$");
320 # we have to copy because e.g. GNU grep gets huffy if we have
321 # a symlink forest to another disk (it complains about too many
322 # levels of symbolic links, even if we have only two)
0c5d4ba3 323 is(symlink("TEST$$","c"), 1, "symlink");
4ba7095c 324 $foo = `grep perl c 2>&1`;
0c5d4ba3 325 ok($foo, "found perl in c");
44a8e56a 326 unlink 'c';
4ba7095c 327 unlink("TEST$$");
378cc40b 328}
f783569b 329
62a28c97 330my $tmpfile = tempfile();
331open IOFSCOM, ">$tmpfile" or die "Could not write IOfs.tmp: $!";
0c5d4ba3 332print IOFSCOM 'helloworld';
333close(IOFSCOM);
334
335# TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP,
336# as per UNIX FAQ.
337
338SKIP: {
63720136 339# Check truncating a closed file.
62a28c97 340 eval { truncate $tmpfile, 5; };
90ddc76f 341
090bf15b 342 skip("no truncate - $@", 8) if $@;
0c5d4ba3 343
62a28c97 344 is(-s $tmpfile, 5, "truncation to five bytes");
0c5d4ba3 345
62a28c97 346 truncate $tmpfile, 0;
0c5d4ba3 347
62a28c97 348 ok(-z $tmpfile, "truncation to zero bytes");
0c5d4ba3 349
7a2cf369 350#these steps are necessary to check if file is really truncated
351#On Win95, FH is updated, but file properties aren't
62a28c97 352 open(FH, ">$tmpfile") or die "Can't create $tmpfile";
7a2cf369 353 print FH "x\n" x 200;
354 close FH;
355
63720136 356# Check truncating an open file.
62a28c97 357 open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending";
0c5d4ba3 358
359 binmode FH;
360 select FH;
361 $| = 1;
362 select STDOUT;
363
364 {
365 use strict;
366 print FH "x\n" x 200;
367 ok(truncate(FH, 200), "fh resize to 200");
62b86938 368 }
0c5d4ba3 369
370 if ($needs_fh_reopen) {
62a28c97 371 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile";
0c5d4ba3 372 }
90ddc76f 373
090bf15b 374 SKIP: {
375 if ($^O eq 'vos') {
376 skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5);
377 }
0c5d4ba3 378
62a28c97 379 is(-s $tmpfile, 200, "fh resize to 200 working (filename check)");
63720136 380
090bf15b 381 ok(truncate(FH, 0), "fh resize to zero");
0c5d4ba3 382
090bf15b 383 if ($needs_fh_reopen) {
62a28c97 384 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile";
090bf15b 385 }
0c5d4ba3 386
62a28c97 387 ok(-z $tmpfile, "fh resize to zero working (filename check)");
7a2cf369 388
090bf15b 389 close FH;
390
62a28c97 391 open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending";
090bf15b 392
393 binmode FH;
394 select FH;
395 $| = 1;
396 select STDOUT;
397
398 {
399 use strict;
400 print FH "x\n" x 200;
401 ok(truncate(*FH{IO}, 100), "fh resize by IO slot");
402 }
403
404 if ($needs_fh_reopen) {
62a28c97 405 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile";
090bf15b 406 }
407
62a28c97 408 is(-s $tmpfile, 100, "fh resize by IO slot working");
090bf15b 409
410 close FH;
411 }
f783569b 412}
80252599 413
65cb15a1 414# check if rename() can be used to just change case of filename
20dd405c 415SKIP: {
416 skip "Works in Cygwin only if check_case is set to relaxed", 1
1a36314c 417 if ($ENV{'CYGWIN'} && ($ENV{'CYGWIN'} =~ /check_case:(?:adjust|strict)/));
20dd405c 418
62a28c97 419 chdir "./$tmpdir";
d5fc3e70 420 open(FH,'>x') || die "Can't create x";
421 close(FH);
0c5d4ba3 422 rename('x', 'X');
3ed9f8f7 423
0c5d4ba3 424 # this works on win32 only, because fs isn't casesensitive
425 ok(-e 'X', "rename working");
8268670f 426
20dd405c 427 1 while unlink 'X';
0c5d4ba3 428 chdir $wd || die "Can't cd back to $wd";
73077d53 429}
65cb15a1 430
80252599 431# check if rename() works on directories
0c5d4ba3 432if ($^O eq 'VMS') {
9df548ee 433 # must have delete access to rename a directory
62a28c97 434 `set file $tmpdir.dir/protection=o:d`;
7aa55bb4 435 ok(rename("$tmpdir.dir", "$tmpdir1.dir"), "rename on directories") ||
20dd405c 436 print "# errno: $!\n";
fc8d54b0 437}
438else {
62a28c97 439 ok(rename($tmpdir, $tmpdir1), "rename on directories");
6d738113 440}
0c5d4ba3 441
62a28c97 442ok(-d $tmpdir1, "rename on directories working");
80252599 443
1937c63e 444{
445 # Change 26011: Re: A surprising segfault
446 # to make sure only that these obfuscated sentences will not crash.
447
448 map chmod(+()), ('')x68;
449 ok(1, "extend sp in pp_chmod");
450
451 map chown(+()), ('')x68;
452 ok(1, "extend sp in pp_chown");
453}
454
62a28c97 455# need to remove $tmpdir if rename() in test 28 failed!
456END { rmdir $tmpdir1; rmdir $tmpdir; }