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') || ($^O eq 'NetWare')) { 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' || $^O eq 'NetWare' || 40 $^O eq 'dos' || $^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 $^O eq 'dos' 57 # Not needed on HPFS, but needed on HPFS386 ?! 58 || $^O eq 'os2'; 59 60$needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); 61 62my $skip_mode_checks = 63 $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; 64 65plan tests => 61; 66 67my $tmpdir = tempfile(); 68my $tmpdir1 = tempfile(); 69 70if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { 71 `rmdir /s /q $tmpdir 2>nul`; 72 `mkdir $tmpdir`; 73} 74elsif ($^O eq 'VMS') { 75 `if f\$search("[.$tmpdir]*.*") .nes. "" then delete/nolog/noconfirm [.$tmpdir]*.*.*`; 76 `if f\$search("$tmpdir.dir") .nes. "" then set file/prot=o:rwed $tmpdir.dir;`; 77 `if f\$search("$tmpdir.dir") .nes. "" then delete/nolog/noconfirm $tmpdir.dir;`; 78 `create/directory [.$tmpdir]`; 79} 80else { 81 `rm -f $tmpdir 2>/dev/null; mkdir $tmpdir 2>/dev/null`; 82} 83 84chdir $tmpdir; 85 86`/bin/rm -rf a b c x` if -x '/bin/rm'; 87 88umask(022); 89 90SKIP: { 91 skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare'); 92 93 is((umask(0)&0777), 022, 'umask'), 94} 95 96open(FH,'>x') || die "Can't create x"; 97close(FH); 98open(FH,'>a') || die "Can't create a"; 99close(FH); 100 101my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 102 $blksize,$blocks,$a_mode); 103 104SKIP: { 105 skip("no link", 4) unless $has_link; 106 107 ok(link('a','b'), "link a b"); 108 ok(link('b','c'), "link b c"); 109 110 $a_mode = (stat('a'))[2]; 111 112 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 113 $blksize,$blocks) = stat('c'); 114 115 SKIP: { 116 skip "no nlink", 1 if $Config{dont_use_nlink}; 117 118 is($nlink, 3, "link count of triply-linked file"); 119 } 120 121 SKIP: { 122 skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos'; 123 skip "no mode checks", 1 if $skip_mode_checks; 124 125 is(sprintf("0%o", $mode & 0777), 126 sprintf("0%o", $a_mode & 0777), 127 "mode of triply-linked file"); 128 } 129} 130 131$newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777; 132 133is(chmod($newmode,'a'), 1, "chmod succeeding"); 134 135SKIP: { 136 skip("no link", 7) unless $has_link; 137 138 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 139 $blksize,$blocks) = stat('c'); 140 141 SKIP: { 142 skip "no mode checks", 1 if $skip_mode_checks; 143 144 is($mode & 0777, $newmode, "chmod going through"); 145 } 146 147 $newmode = 0700; 148 chmod 0444, 'x'; 149 $newmode = 0666; 150 151 is(chmod($newmode,'c','x'), 2, "chmod two files"); 152 153 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 154 $blksize,$blocks) = stat('c'); 155 156 SKIP: { 157 skip "no mode checks", 1 if $skip_mode_checks; 158 159 is($mode & 0777, $newmode, "chmod going through to c"); 160 } 161 162 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 163 $blksize,$blocks) = stat('x'); 164 165 SKIP: { 166 skip "no mode checks", 1 if $skip_mode_checks; 167 168 is($mode & 0777, $newmode, "chmod going through to x"); 169 } 170 171 is(unlink('b','x'), 2, "unlink two files"); 172 173 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 174 $blksize,$blocks) = stat('b'); 175 176 is($ino, undef, "ino of removed file b should be undef"); 177 178 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 179 $blksize,$blocks) = stat('x'); 180 181 is($ino, undef, "ino of removed file x should be undef"); 182} 183 184SKIP: { 185 skip "no fchmod", 7 unless ($Config{d_fchmod} || "") eq "define"; 186 ok(open(my $fh, "<", "a"), "open a"); 187 is(chmod(0, $fh), 1, "fchmod"); 188 $mode = (stat "a")[2]; 189 SKIP: { 190 skip "no mode checks", 1 if $skip_mode_checks; 191 skip "chmod(0, FH) means assume user defaults on VMS", 1 if $^O eq 'VMS'; 192 is($mode & 0777, 0, "perm reset"); 193 } 194 is(chmod($newmode, "a"), 1, "fchmod"); 195 $mode = (stat $fh)[2]; 196 SKIP: { 197 skip "no mode checks", 1 if $skip_mode_checks; 198 is($mode & 0777, $newmode, "perm restored"); 199 } 200 201 # [perl #122703] 202 close $fh; 203 $! = 0; 204 ok(!chmod(0666, $fh), "chmod through closed handle fails"); 205 isnt($!+0, 0, "and errno was set"); 206} 207 208SKIP: { 209 skip "no fchown", 3 unless ($Config{d_fchown} || "") eq "define"; 210 open(my $fh, "<", "a"); 211 is(chown(-1, -1, $fh), 1, "fchown"); 212 213 # [perl #122703] 214 # chown() behaved correctly, but there was no test for the chown() 215 # on closed handle case 216 close $fh; 217 $! = 0; 218 ok(!chown(-1, -1, $fh), "chown on closed handle fails"); 219 isnt($!+0, 0, "and errno was set"); 220} 221 222SKIP: { 223 skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define"; 224 open(my $fh, "<", "a"); 225 eval { chmod(0777, $fh); }; 226 like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented"); 227} 228 229SKIP: { 230 skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define"; 231 open(my $fh, "<", "a"); 232 eval { chown(0, 0, $fh); }; 233 like($@, qr/^The f?chown function is unimplemented at/, "fchown is unimplemented"); 234} 235 236is(rename('a','b'), 1, "rename a b"); 237 238($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 239 $blksize,$blocks) = stat('a'); 240 241is($ino, undef, "ino of renamed file a should be undef"); 242 243$delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem 244chmod 0777, 'b'; 245 246$ut = 500000000; 247 248note("basic check of atime and mtime"); 249$foo = (utime $ut,$ut + $delta,'b'); 250is($foo, 1, "utime"); 251check_utime_result($ut, $accurate_timestamps, $delta); 252 253utime undef, undef, 'b'; 254($atime,$mtime) = (stat 'b')[8,9]; 255note("# utime undef, undef --> $atime, $mtime"); 256isnt($atime, $ut, 'atime: utime called with two undefs'); 257isnt($mtime, $ut + $delta, 'mtime: utime called with two undefs'); 258 259SKIP: { 260 skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define"; 261 note("check futimes"); 262 open(my $fh, "<", 'b'); 263 $foo = (utime $ut,$ut + $delta, $fh); 264 is($foo, 1, "futime"); 265 check_utime_result($ut, $accurate_timestamps, $delta); 266 # [perl #122703] 267 close $fh; 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/Netware specific test", 2 295 unless ($^O eq 'MSWin32') || ($^O eq 'NetWare'); 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') || ($^O eq 'NetWare')) { 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') || ($^O eq 'NetWare'); 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 | ); 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