1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require "./test.pl"; 6 set_up_inc('../lib'); 7} 8 9use Config; 10 11my $Is_VMSish = ($^O eq 'VMS'); 12 13if ($^O eq 'MSWin32') { 14 # under minitest, buildcustomize sets this to 1, which means 15 # nlinks isn't populated properly, allow our tests to pass 16 ${^WIN32_SLOPPY_STAT} = 0; 17} 18 19if ($^O eq 'MSWin32') { 20 $wd = `cd`; 21} 22elsif ($^O eq 'VMS') { 23 $wd = `show default`; 24} 25elsif ( $^O =~ /android/ || $^O eq 'nto' ) { 26 # On Android and Blackberry 10, pwd is a shell builtin, so plain `pwd` 27 # won't cut it 28 $wd = `sh -c pwd`; 29} 30else { 31 $wd = `pwd`; 32} 33chomp($wd); 34 35die "Can't get current working directory" if(!$wd); 36 37my $has_link = $Config{d_link}; 38my $accurate_timestamps = 39 !($^O eq 'MSWin32' || 40 $^O eq 'os2' || 41 $^O eq 'cygwin' || $^O eq 'amigaos' || 42 $wd =~ m#$Config{afsroot}/# 43 ); 44 45if (defined &Win32::IsWinNT && Win32::IsWinNT()) { 46 if (Win32::FsType() eq 'NTFS') { 47 $has_link = 1; 48 $accurate_timestamps = 1; 49 } 50 else { 51 $has_link = 0; 52 } 53} 54 55my $needs_fh_reopen = 56 # Not needed on HPFS, but needed on HPFS386 ?! 57 $^O eq 'os2'; 58 59$needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); 60 61my $skip_mode_checks = 62 $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; 63 64plan tests => 61; 65 66my $tmpdir = tempfile(); 67my $tmpdir1 = tempfile(); 68 69if ($^O eq 'MSWin32') { 70 `rmdir /s /q $tmpdir 2>nul`; 71 `mkdir $tmpdir`; 72} 73elsif ($^O eq 'VMS') { 74 `if f\$search("[.$tmpdir]*.*") .nes. "" then delete/nolog/noconfirm [.$tmpdir]*.*.*`; 75 `if f\$search("$tmpdir.dir") .nes. "" then set file/prot=o:rwed $tmpdir.dir;`; 76 `if f\$search("$tmpdir.dir") .nes. "" then delete/nolog/noconfirm $tmpdir.dir;`; 77 `create/directory [.$tmpdir]`; 78} 79else { 80 `rm -f $tmpdir 2>/dev/null; mkdir $tmpdir 2>/dev/null`; 81} 82 83chdir $tmpdir; 84 85`/bin/rm -rf a b c x` if -x '/bin/rm'; 86 87umask(022); 88 89SKIP: { 90 skip "bogus umask", 1 if ($^O eq 'MSWin32'); 91 92 is((umask(0)&0777), 022, 'umask'), 93} 94 95open(FH,'>x') || die "Can't create x"; 96close(FH); 97open(FH,'>a') || die "Can't create a"; 98close(FH); 99 100my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 101 $blksize,$blocks,$a_mode); 102 103SKIP: { 104 skip("no link", 4) unless $has_link; 105 106 ok(link('a','b'), "link a b"); 107 ok(link('b','c'), "link b c"); 108 109 $a_mode = (stat('a'))[2]; 110 111 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 112 $blksize,$blocks) = stat('c'); 113 114 SKIP: { 115 skip "no nlink", 1 if $Config{dont_use_nlink}; 116 117 is($nlink, 3, "link count of triply-linked file"); 118 } 119 120 SKIP: { 121 skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos'; 122 skip "no mode checks", 1 if $skip_mode_checks; 123 124 is(sprintf("0%o", $mode & 0777), 125 sprintf("0%o", $a_mode & 0777), 126 "mode of triply-linked file"); 127 } 128} 129 130$newmode = ($^O eq 'MSWin32') ? 0444 : 0777; 131 132is(chmod($newmode,'a'), 1, "chmod succeeding"); 133 134SKIP: { 135 skip("no link", 7) unless $has_link; 136 137 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 138 $blksize,$blocks) = stat('c'); 139 140 SKIP: { 141 skip "no mode checks", 1 if $skip_mode_checks; 142 143 is($mode & 0777, $newmode, "chmod going through"); 144 } 145 146 $newmode = 0700; 147 chmod 0444, 'x'; 148 $newmode = 0666; 149 150 is(chmod($newmode,'c','x'), 2, "chmod two files"); 151 152 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 153 $blksize,$blocks) = stat('c'); 154 155 SKIP: { 156 skip "no mode checks", 1 if $skip_mode_checks; 157 158 is($mode & 0777, $newmode, "chmod going through to c"); 159 } 160 161 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 162 $blksize,$blocks) = stat('x'); 163 164 SKIP: { 165 skip "no mode checks", 1 if $skip_mode_checks; 166 167 is($mode & 0777, $newmode, "chmod going through to x"); 168 } 169 170 is(unlink('b','x'), 2, "unlink two files"); 171 172 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 173 $blksize,$blocks) = stat('b'); 174 175 is($ino, undef, "ino of removed file b should be undef"); 176 177 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 178 $blksize,$blocks) = stat('x'); 179 180 is($ino, undef, "ino of removed file x should be undef"); 181} 182 183SKIP: { 184 skip "no fchmod", 7 unless ($Config{d_fchmod} || "") eq "define"; 185 ok(open(my $fh, "<", "a"), "open a"); 186 is(chmod(0, $fh), 1, "fchmod"); 187 $mode = (stat "a")[2]; 188 SKIP: { 189 skip "no mode checks", 1 if $skip_mode_checks; 190 skip "chmod(0, FH) means assume user defaults on VMS", 1 if $^O eq 'VMS'; 191 is($mode & 0777, 0, "perm reset"); 192 } 193 is(chmod($newmode, "a"), 1, "fchmod"); 194 $mode = (stat $fh)[2]; 195 SKIP: { 196 skip "no mode checks", 1 if $skip_mode_checks; 197 is($mode & 0777, $newmode, "perm restored"); 198 } 199 200 # [perl #122703] 201 close $fh; 202 $! = 0; 203 ok(!chmod(0666, $fh), "chmod through closed handle fails"); 204 isnt($!+0, 0, "and errno was set"); 205} 206 207SKIP: { 208 skip "no fchown", 3 unless ($Config{d_fchown} || "") eq "define"; 209 open(my $fh, "<", "a"); 210 is(chown(-1, -1, $fh), 1, "fchown"); 211 212 # [perl #122703] 213 # chown() behaved correctly, but there was no test for the chown() 214 # on closed handle case 215 close $fh; 216 $! = 0; 217 ok(!chown(-1, -1, $fh), "chown on closed handle fails"); 218 isnt($!+0, 0, "and errno was set"); 219} 220 221SKIP: { 222 skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define"; 223 open(my $fh, "<", "a"); 224 eval { chmod(0777, $fh); }; 225 like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented"); 226} 227 228SKIP: { 229 skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define"; 230 open(my $fh, "<", "a"); 231 eval { chown(0, 0, $fh); }; 232 like($@, qr/^The f?chown function is unimplemented at/, "fchown is unimplemented"); 233} 234 235is(rename('a','b'), 1, "rename a b"); 236 237($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 238 $blksize,$blocks) = stat('a'); 239 240is($ino, undef, "ino of renamed file a should be undef"); 241 242$delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem 243chmod 0777, 'b'; 244 245$ut = 500000000; 246 247note("basic check of atime and mtime"); 248$foo = (utime $ut,$ut + $delta,'b'); 249is($foo, 1, "utime"); 250check_utime_result($ut, $accurate_timestamps, $delta); 251 252utime undef, undef, 'b'; 253($atime,$mtime) = (stat 'b')[8,9]; 254note("# utime undef, undef --> $atime, $mtime"); 255isnt($atime, $ut, 'atime: utime called with two undefs'); 256isnt($mtime, $ut + $delta, 'mtime: utime called with two undefs'); 257 258SKIP: { 259 skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define"; 260 note("check futimes"); 261 open(my $fh, "<", 'b'); 262 $foo = (utime $ut,$ut + $delta, $fh); 263 is($foo, 1, "futime"); 264 check_utime_result($ut, $accurate_timestamps, $delta); 265 # [perl #122703] 266 close $fh; 267 $! = 0; 268 ok(!utime($ut,$ut + $delta, $fh), 269 "utime fails on a closed file handle"); 270 isnt($!+0, 0, "and errno was set"); 271} 272 273SKIP: { 274 skip "has futimes", 1 if ($Config{d_futimes} || "") eq "define"; 275 open(my $fh, "<", "b") || die; 276 eval { utime(undef, undef, $fh); }; 277 like($@, qr/^The futimes function is unimplemented at/, "futimes is unimplemented"); 278} 279 280is(unlink('b'), 1, "unlink b"); 281 282($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 283 $blksize,$blocks) = stat('b'); 284is($ino, undef, "ino of unlinked file b should be undef"); 285unlink 'c'; 286 287chdir $wd || die "Can't cd back to '$wd' ($!)"; 288 289# Yet another way to look for links (perhaps those that cannot be 290# created by perl?). Hopefully there is an ls utility in your 291# %PATH%. N.B. that $^O is 'cygwin' on Cygwin. 292 293SKIP: { 294 skip "Win32 specific test", 2 295 unless ($^O eq 'MSWin32'); 296 skip "No symbolic links found to test with", 2 297 unless `ls -l perl 2>nul` =~ /^l.*->/; 298 299 system("cp TEST TEST$$"); 300 # we have to copy because e.g. GNU grep gets huffy if we have 301 # a symlink forest to another disk (it complains about too many 302 # levels of symbolic links, even if we have only two) 303 is(symlink("TEST$$","c"), 1, "symlink"); 304 $foo = `grep perl c 2>&1`; 305 ok($foo, "found perl in c"); 306 unlink 'c'; 307 unlink("TEST$$"); 308} 309 310my $tmpfile = tempfile(); 311open IOFSCOM, ">$tmpfile" or die "Could not write IOfs.tmp: $!"; 312print IOFSCOM 'helloworld'; 313close(IOFSCOM); 314 315# TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP, 316# as per UNIX FAQ. 317 318SKIP: { 319# Check truncating a closed file. 320 eval { truncate $tmpfile, 5; }; 321 322 skip("no truncate - $@", 8) if $@; 323 324 is(-s $tmpfile, 5, "truncation to five bytes"); 325 326 truncate $tmpfile, 0; 327 328 ok(-z $tmpfile, "truncation to zero bytes"); 329 330#these steps are necessary to check if file is really truncated 331#On Win95, FH is updated, but file properties aren't 332 open(FH, ">$tmpfile") or die "Can't create $tmpfile"; 333 print FH "x\n" x 200; 334 close FH; 335 336# Check truncating an open file. 337 open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; 338 339 binmode FH; 340 select FH; 341 $| = 1; 342 select STDOUT; 343 344 { 345 use strict; 346 print FH "x\n" x 200; 347 ok(truncate(FH, 200), "fh resize to 200"); 348 } 349 350 if ($needs_fh_reopen) { 351 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; 352 } 353 354 is(-s $tmpfile, 200, "fh resize to 200 working (filename check)"); 355 356 ok(truncate(FH, 0), "fh resize to zero"); 357 358 if ($needs_fh_reopen) { 359 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; 360 } 361 362 ok(-z $tmpfile, "fh resize to zero working (filename check)"); 363 364 close FH; 365 366 open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; 367 368 binmode FH; 369 select FH; 370 $| = 1; 371 select STDOUT; 372 373 { 374 use strict; 375 print FH "x\n" x 200; 376 ok(truncate(*FH{IO}, 100), "fh resize by IO slot"); 377 } 378 379 if ($needs_fh_reopen) { 380 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; 381 } 382 383 is(-s $tmpfile, 100, "fh resize by IO slot working"); 384 385 close FH; 386 387 my $n = "for_fs_dot_t$$"; 388 open FH, ">$n" or die "open $n: $!"; 389 print FH "bloh blah bla\n"; 390 close FH or die "close $n: $!"; 391 eval "truncate $n, 0; 1" or die; 392 ok !-z $n, 'truncate(word) does not fall back to file name'; 393 unlink $n; 394} 395 396# check if rename() can be used to just change case of filename 397SKIP: { 398 skip "Works in Cygwin only if check_case is set to relaxed", 1 399 if ($ENV{'CYGWIN'} && ($ENV{'CYGWIN'} =~ /check_case:(?:adjust|strict)/)); 400 401 chdir "./$tmpdir"; 402 open(FH,'>x') || die "Can't create x"; 403 close(FH); 404 rename('x', 'X'); 405 406 # this works on win32 only, because fs isn't casesensitive 407 ok(-e 'X', "rename working"); 408 409 unlink_all 'X'; 410 chdir $wd || die "Can't cd back to $wd"; 411} 412 413SKIP: 414{ 415 $Config{d_rename} 416 or skip "Cannot rename directories with link()", 2; 417 # check if rename() works on directories 418 if ($^O eq 'VMS') { 419 # must have delete access to rename a directory 420 `set file $tmpdir.dir/protection=o:d`; 421 ok(rename("$tmpdir.dir", "$tmpdir1.dir"), "rename on directories") || 422 print "# errno: $!\n"; 423 } 424 else { 425 ok(rename($tmpdir, $tmpdir1), "rename on directories"); 426 } 427 428 ok(-d $tmpdir1, "rename on directories working"); 429} 430 431{ 432 # Change 26011: Re: A surprising segfault 433 # to make sure only that these obfuscated sentences will not crash. 434 435 map chmod(+()), ('')x68; 436 ok(1, "extend sp in pp_chmod"); 437 438 map chown(+()), ('')x68; 439 ok(1, "extend sp in pp_chown"); 440} 441 442# Calling unlink on a directory without -U and privileges will always fail, but 443# it should set errno to EISDIR even though unlink(2) is never called. 444SKIP: { 445 if (is_miniperl && !eval 'require Errno') { 446 skip "Errno not built yet", 3; 447 } 448 require Errno; 449 450 my $tmpdir = tempfile(); 451 if ($^O eq 'MSWin32') { 452 `mkdir $tmpdir`; 453 } 454 elsif ($^O eq 'VMS') { 455 `create/directory [.$tmpdir]`; 456 } 457 else { 458 `mkdir $tmpdir 2>/dev/null`; 459 } 460 461 # errno should be set even though unlink(2) is not called 462 local $!; 463 is(unlink($tmpdir), 0, "can't unlink directory without -U and privileges"); 464 is(0+$!, Errno::EISDIR(), "unlink directory without -U sets errno"); 465 466 rmdir $tmpdir; 467 468 # errno should be set by failed lstat(2) call 469 $! = 0; 470 unlink($tmpdir); 471 is(0+$!, Errno::ENOENT(), "unlink non-existent directory without -U sets ENOENT"); 472} 473 474# need to remove $tmpdir if rename() in test 28 failed! 475END { rmdir $tmpdir1; rmdir $tmpdir; } 476 477sub check_utime_result { 478 ($ut, $accurate_timestamps, $delta) = @_; 479 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 480 $blksize,$blocks) = stat('b'); 481 482 SKIP: { 483 skip "bogus inode num", 1 if ($^O eq 'MSWin32'); 484 ok($ino, 'non-zero inode num'); 485 } 486 487 SKIP: { 488 skip "filesystem atime/mtime granularity too low", 2 489 unless $accurate_timestamps; 490 491 if ($^O eq 'vos') { 492 skip ("# TODO - hit VOS bug posix-2055 - access time does not follow POSIX rules for an open file.", 2); 493 } 494 495 note("# atime - $atime mtime - $mtime delta - $delta"); 496 if($atime == $ut && $mtime == $ut + $delta) { 497 pass('atime: granularity test'); 498 pass('mtime: granularity test'); 499 } 500 else { 501 # Operating systems whose filesystems may be mounted with the noatime option 502 # RT 132663 503 my %noatime_oses = map { $_ => 1 } ( qw| haiku netbsd dragonfly | ); 504 if ($^O =~ /\blinux\b/i) { 505 note("# Maybe stat() cannot get the correct atime, ". 506 "as happens via NFS on linux?"); 507 $foo = (utime 400000000,$ut + 2*$delta,'b'); 508 my ($new_atime, $new_mtime) = (stat('b'))[8,9]; 509 note("# newatime - $new_atime nemtime - $new_mtime"); 510 if ($new_atime == $atime && $new_mtime - $mtime == $delta) { 511 pass("atime - accounted for possible NFS/glibc2.2 bug on linux"); 512 pass("mtime - accounted for possible NFS/glibc2.2 bug on linux"); 513 } 514 else { 515 fail("atime - $atime/$new_atime $mtime/$new_mtime"); 516 fail("mtime - $atime/$new_atime $mtime/$new_mtime"); 517 } 518 } 519 elsif ($^O eq 'VMS') { 520 # why is this 1 second off? 521 is( $atime, $ut + 1, 'atime: VMS' ); 522 is( $mtime, $ut + $delta, 'mtime: VMS' ); 523 } 524 elsif ($noatime_oses{$^O}) { 525 pass("atime not updated"); 526 is($mtime, 500000001, 'mtime'); 527 } 528 else { 529 fail("atime: default case"); 530 fail("mtime: default case"); 531 } 532 } # END failed atime mtime 'else' block 533 } # END granularity SKIP block 534} 535