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 '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') { 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'); 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') ? 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 $! = 0; 269 ok(!utime($ut,$ut + $delta, $fh), 270 "utime fails on a closed file handle"); 271 isnt($!+0, 0, "and errno was set"); 272} 273 274SKIP: { 275 skip "has futimes", 1 if ($Config{d_futimes} || "") eq "define"; 276 open(my $fh, "<", "b") || die; 277 eval { utime(undef, undef, $fh); }; 278 like($@, qr/^The futimes function is unimplemented at/, "futimes is unimplemented"); 279} 280 281is(unlink('b'), 1, "unlink b"); 282 283($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 284 $blksize,$blocks) = stat('b'); 285is($ino, undef, "ino of unlinked file b should be undef"); 286unlink 'c'; 287 288chdir $wd || die "Can't cd back to '$wd' ($!)"; 289 290# Yet another way to look for links (perhaps those that cannot be 291# created by perl?). Hopefully there is an ls utility in your 292# %PATH%. N.B. that $^O is 'cygwin' on Cygwin. 293 294SKIP: { 295 skip "Win32 specific test", 2 296 unless ($^O eq 'MSWin32'); 297 skip "No symbolic links found to test with", 2 298 unless `ls -l perl 2>nul` =~ /^l.*->/; 299 300 system("cp TEST TEST$$"); 301 # we have to copy because e.g. GNU grep gets huffy if we have 302 # a symlink forest to another disk (it complains about too many 303 # levels of symbolic links, even if we have only two) 304 is(symlink("TEST$$","c"), 1, "symlink"); 305 $foo = `grep perl c 2>&1`; 306 ok($foo, "found perl in c"); 307 unlink 'c'; 308 unlink("TEST$$"); 309} 310 311my $tmpfile = tempfile(); 312open IOFSCOM, ">$tmpfile" or die "Could not write IOfs.tmp: $!"; 313print IOFSCOM 'helloworld'; 314close(IOFSCOM); 315 316# TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP, 317# as per UNIX FAQ. 318 319SKIP: { 320# Check truncating a closed file. 321 eval { truncate $tmpfile, 5; }; 322 323 skip("no truncate - $@", 8) if $@; 324 325 is(-s $tmpfile, 5, "truncation to five bytes"); 326 327 truncate $tmpfile, 0; 328 329 ok(-z $tmpfile, "truncation to zero bytes"); 330 331#these steps are necessary to check if file is really truncated 332#On Win95, FH is updated, but file properties aren't 333 open(FH, ">$tmpfile") or die "Can't create $tmpfile"; 334 print FH "x\n" x 200; 335 close FH; 336 337# Check truncating an open file. 338 open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; 339 340 binmode FH; 341 select FH; 342 $| = 1; 343 select STDOUT; 344 345 { 346 use strict; 347 print FH "x\n" x 200; 348 ok(truncate(FH, 200), "fh resize to 200"); 349 } 350 351 if ($needs_fh_reopen) { 352 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; 353 } 354 355 is(-s $tmpfile, 200, "fh resize to 200 working (filename check)"); 356 357 ok(truncate(FH, 0), "fh resize to zero"); 358 359 if ($needs_fh_reopen) { 360 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; 361 } 362 363 ok(-z $tmpfile, "fh resize to zero working (filename check)"); 364 365 close FH; 366 367 open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; 368 369 binmode FH; 370 select FH; 371 $| = 1; 372 select STDOUT; 373 374 { 375 use strict; 376 print FH "x\n" x 200; 377 ok(truncate(*FH{IO}, 100), "fh resize by IO slot"); 378 } 379 380 if ($needs_fh_reopen) { 381 close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; 382 } 383 384 is(-s $tmpfile, 100, "fh resize by IO slot working"); 385 386 close FH; 387 388 my $n = "for_fs_dot_t$$"; 389 open FH, ">$n" or die "open $n: $!"; 390 print FH "bloh blah bla\n"; 391 close FH or die "close $n: $!"; 392 eval "truncate $n, 0; 1" or die; 393 ok !-z $n, 'truncate(word) does not fall back to file name'; 394 unlink $n; 395} 396 397# check if rename() can be used to just change case of filename 398SKIP: { 399 skip "Works in Cygwin only if check_case is set to relaxed", 1 400 if ($ENV{'CYGWIN'} && ($ENV{'CYGWIN'} =~ /check_case:(?:adjust|strict)/)); 401 402 chdir "./$tmpdir"; 403 open(FH,'>x') || die "Can't create x"; 404 close(FH); 405 rename('x', 'X'); 406 407 # this works on win32 only, because fs isn't casesensitive 408 ok(-e 'X', "rename working"); 409 410 unlink_all 'X'; 411 chdir $wd || die "Can't cd back to $wd"; 412} 413 414SKIP: 415{ 416 $Config{d_rename} 417 or skip "Cannot rename directories with link()", 2; 418 # check if rename() works on directories 419 if ($^O eq 'VMS') { 420 # must have delete access to rename a directory 421 `set file $tmpdir.dir/protection=o:d`; 422 ok(rename("$tmpdir.dir", "$tmpdir1.dir"), "rename on directories") || 423 print "# errno: $!\n"; 424 } 425 else { 426 ok(rename($tmpdir, $tmpdir1), "rename on directories"); 427 } 428 429 ok(-d $tmpdir1, "rename on directories working"); 430} 431 432{ 433 # Change 26011: Re: A surprising segfault 434 # to make sure only that these obfuscated sentences will not crash. 435 436 map chmod(+()), ('')x68; 437 ok(1, "extend sp in pp_chmod"); 438 439 map chown(+()), ('')x68; 440 ok(1, "extend sp in pp_chown"); 441} 442 443# Calling unlink on a directory without -U and privileges will always fail, but 444# it should set errno to EISDIR even though unlink(2) is never called. 445SKIP: { 446 if (is_miniperl && !eval 'require Errno') { 447 skip "Errno not built yet", 3; 448 } 449 require Errno; 450 451 my $tmpdir = tempfile(); 452 if ($^O eq 'MSWin32') { 453 `mkdir $tmpdir`; 454 } 455 elsif ($^O eq 'VMS') { 456 `create/directory [.$tmpdir]`; 457 } 458 else { 459 `mkdir $tmpdir 2>/dev/null`; 460 } 461 462 # errno should be set even though unlink(2) is not called 463 local $!; 464 is(unlink($tmpdir), 0, "can't unlink directory without -U and privileges"); 465 is(0+$!, Errno::EISDIR(), "unlink directory without -U sets errno"); 466 467 rmdir $tmpdir; 468 469 # errno should be set by failed lstat(2) call 470 $! = 0; 471 unlink($tmpdir); 472 is(0+$!, Errno::ENOENT(), "unlink non-existent directory without -U sets ENOENT"); 473} 474 475# need to remove $tmpdir if rename() in test 28 failed! 476END { rmdir $tmpdir1; rmdir $tmpdir; } 477 478sub check_utime_result { 479 ($ut, $accurate_timestamps, $delta) = @_; 480 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 481 $blksize,$blocks) = stat('b'); 482 483 SKIP: { 484 skip "bogus inode num", 1 if ($^O eq 'MSWin32'); 485 ok($ino, 'non-zero inode num'); 486 } 487 488 SKIP: { 489 skip "filesystem atime/mtime granularity too low", 2 490 unless $accurate_timestamps; 491 492 if ($^O eq 'vos') { 493 skip ("# TODO - hit VOS bug posix-2055 - access time does not follow POSIX rules for an open file.", 2); 494 } 495 496 note("# atime - $atime mtime - $mtime delta - $delta"); 497 if($atime == $ut && $mtime == $ut + $delta) { 498 pass('atime: granularity test'); 499 pass('mtime: granularity test'); 500 } 501 else { 502 # Operating systems whose filesystems may be mounted with the noatime option 503 # RT 132663 504 my %noatime_oses = map { $_ => 1 } ( qw| haiku netbsd dragonfly | ); 505 if ($^O =~ /\blinux\b/i) { 506 note("# Maybe stat() cannot get the correct atime, ". 507 "as happens via NFS on linux?"); 508 $foo = (utime 400000000,$ut + 2*$delta,'b'); 509 my ($new_atime, $new_mtime) = (stat('b'))[8,9]; 510 note("# newatime - $new_atime nemtime - $new_mtime"); 511 if ($new_atime == $atime && $new_mtime - $mtime == $delta) { 512 pass("atime - accounted for possible NFS/glibc2.2 bug on linux"); 513 pass("mtime - accounted for possible NFS/glibc2.2 bug on linux"); 514 } 515 else { 516 fail("atime - $atime/$new_atime $mtime/$new_mtime"); 517 fail("mtime - $atime/$new_atime $mtime/$new_mtime"); 518 } 519 } 520 elsif ($^O eq 'VMS') { 521 # why is this 1 second off? 522 is( $atime, $ut + 1, 'atime: VMS' ); 523 is( $mtime, $ut + $delta, 'mtime: VMS' ); 524 } 525 elsif ($noatime_oses{$^O}) { 526 pass("atime not updated"); 527 is($mtime, 500000001, 'mtime'); 528 } 529 else { 530 fail("atime: default case"); 531 fail("mtime: default case"); 532 } 533 } # END failed atime mtime 'else' block 534 } # END granularity SKIP block 535} 536