t/io/fs.t

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