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