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