This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: fchmod, fchown, fchdir
[perl5.git] / t / io / fs.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require "./test.pl";
7 }
8
9 use Config;
10 use File::Spec::Functions;
11
12 my $Is_MacOS  = ($^O eq 'MacOS');
13 my $Is_VMSish = ($^O eq 'VMS');
14
15 if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
16     $wd = `cd`;
17 } elsif ($^O eq 'VMS') {
18     $wd = `show default`;
19 } else {
20     $wd = `pwd`;
21 }
22 chomp($wd);
23
24 my $has_link            = $Config{d_link};
25 my $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
33 if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
34     if (Win32::FsType() eq 'NTFS') {
35         $has_link            = 1;
36         $accurate_timestamps = 1;
37     }
38 }
39
40 my $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
47 my $skip_mode_checks =
48     $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
49
50 plan tests => 42;
51
52
53 if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
54     `rmdir /s /q tmp 2>nul`;
55     `mkdir tmp`;
56 }
57 elsif ($^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 }
62 elsif ($Is_MacOS) {
63     rmdir "tmp"; mkdir "tmp";
64 }
65 else {
66     `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
67 }
68
69 chdir catdir(curdir(), 'tmp');
70
71 `/bin/rm -rf a b c x` if -x '/bin/rm';
72
73 umask(022);
74
75 SKIP: {
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
81 open(fh,'>x') || die "Can't create x";
82 close(fh);
83 open(fh,'>a') || die "Can't create a";
84 close(fh);
85
86 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
87     $blksize,$blocks);
88
89 SKIP: {
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
118 is(chmod($newmode,'a'), 1, "chmod succeeding");
119
120 SKIP: {
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
169 SKIP: {
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     is($mode & 0777, 0, "perm reset");
175     is(chmod($newmode, "a"), 1, "fchmod");
176     $mode = (stat $fh)[2];
177     is($mode & 0777, $newmode, "perm restored");
178 }
179
180 SKIP: {
181     skip "no fchown", 1 unless ($Config{d_fchown} || "") eq "define";
182     open(my $fh, "<", "a");
183     is(chown(-1, -1, $fh), 1, "fchown");
184 }
185
186 SKIP: {
187     skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define";
188     open(my $fh, "<", "a");
189     eval { chmod(0777, $fh); };
190     like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented");
191 }
192
193 SKIP: {
194     skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define";
195     open(my $fh, "<", "a");
196     eval { chown(0, 0, $fh); };
197     like($@, qr/^The fchown function is unimplemented at/, "fchown is unimplemented");
198 }
199
200 is(rename('a','b'), 1, "rename a b");
201
202 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
203  $blksize,$blocks) = stat('a');
204
205 is($ino, undef, "ino of renamed file a should be undef");
206
207 $delta = $accurate_timestamps ? 1 : 2;  # Granularity of time on the filesystem
208 chmod 0777, 'b';
209 $foo = (utime 500000000,500000000 + $delta,'b');
210
211 is($foo, 1, "utime");
212
213 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
214     $blksize,$blocks) = stat('b');
215
216 SKIP: {
217     skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare');
218
219     ok($ino,    'non-zero inode num');
220 }
221
222 SKIP: {
223     skip "filesystem atime/mtime granularity too low", 2
224       unless $accurate_timestamps;
225
226     print "# atime - $atime  mtime - $mtime  delta - $delta\n";
227     if($atime == 500000000 && $mtime == 500000000 + $delta) {
228         pass('atime');
229         pass('mtime');
230     }
231     else {
232         if ($^O =~ /\blinux\b/i) {
233             print "# Maybe stat() cannot get the correct atime, ".
234                   "as happens via NFS on linux?\n";
235             $foo = (utime 400000000,500000000 + 2*$delta,'b');
236             my ($new_atime, $new_mtime) = (stat('b'))[8,9];
237             print "# newatime - $new_atime  nemtime - $new_mtime\n";
238             if ($new_atime == $atime && $new_mtime - $mtime == $delta) {
239                 pass("atime - accounted for possible NFS/glibc2.2 bug on linux");
240                 pass("mtime - accounted for possible NFS/glibc2.2 bug on linux");
241             }
242             else {
243                 fail("atime - $atime/$new_atime $mtime/$new_mtime");
244                 fail("mtime - $atime/$new_atime $mtime/$new_mtime");
245             }
246         }
247         elsif ($^O eq 'VMS') {
248             # why is this 1 second off?
249             is( $atime, 500000001,          'atime' );
250             is( $mtime, 500000000 + $delta, 'mtime' );
251         }
252         elsif ($^O eq 'beos') {
253             SKIP: { skip "atime not updated", 1; }
254             is($mtime, 500000001, 'mtime');
255         }
256         else {
257             fail("atime");
258             fail("mtime");
259         }
260     }
261 }
262
263 is(unlink('b'), 1, "unlink b");
264
265 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
266     $blksize,$blocks) = stat('b');
267 is($ino, undef, "ino of unlinked file b should be undef");
268 unlink 'c';
269
270 chdir $wd || die "Can't cd back to $wd";
271
272 # Yet another way to look for links (perhaps those that cannot be
273 # created by perl?).  Hopefully there is an ls utility in your
274 # %PATH%. N.B. that $^O is 'cygwin' on Cygwin.
275
276 SKIP: {
277     skip "Win32/Netware specific test", 2
278       unless ($^O eq 'MSWin32') || ($^O eq 'NetWare');
279     skip "No symbolic links found to test with", 2
280       unless  `ls -l perl 2>nul` =~ /^l.*->/;
281
282     system("cp TEST TEST$$");
283     # we have to copy because e.g. GNU grep gets huffy if we have
284     # a symlink forest to another disk (it complains about too many
285     # levels of symbolic links, even if we have only two)
286     is(symlink("TEST$$","c"), 1, "symlink");
287     $foo = `grep perl c 2>&1`;
288     ok($foo, "found perl in c");
289     unlink 'c';
290     unlink("TEST$$");
291 }
292
293 unlink "Iofs.tmp";
294 open IOFSCOM, ">Iofs.tmp" or die "Could not write IOfs.tmp: $!";
295 print IOFSCOM 'helloworld';
296 close(IOFSCOM);
297
298 # TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP,
299 # as per UNIX FAQ.
300
301 SKIP: {
302 # Check truncating a closed file.
303     eval { truncate "Iofs.tmp", 5; };
304
305     skip("no truncate - $@", 8) if $@;
306
307     is(-s "Iofs.tmp", 5, "truncation to five bytes");
308
309     truncate "Iofs.tmp", 0;
310
311     ok(-z "Iofs.tmp",    "truncation to zero bytes");
312
313 #these steps are necessary to check if file is really truncated
314 #On Win95, FH is updated, but file properties aren't
315     open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
316     print FH "x\n" x 200;
317     close FH;
318
319 # Check truncating an open file.
320     open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
321
322     binmode FH;
323     select FH;
324     $| = 1;
325     select STDOUT;
326
327     {
328         use strict;
329         print FH "x\n" x 200;
330         ok(truncate(FH, 200), "fh resize to 200");
331     }
332
333     if ($needs_fh_reopen) {
334         close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
335     }
336
337     SKIP: {
338         if ($^O eq 'vos') {
339             skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5);
340         }
341
342         is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
343
344         ok(truncate(FH, 0), "fh resize to zero");
345
346         if ($needs_fh_reopen) {
347             close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
348         }
349
350         ok(-z "Iofs.tmp", "fh resize to zero working (filename check)");
351
352         close FH;
353
354         open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
355
356         binmode FH;
357         select FH;
358         $| = 1;
359         select STDOUT;
360
361         {
362             use strict;
363             print FH "x\n" x 200;
364             ok(truncate(*FH{IO}, 100), "fh resize by IO slot");
365         }
366
367         if ($needs_fh_reopen) {
368             close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
369         }
370
371         is(-s "Iofs.tmp", 100, "fh resize by IO slot working");
372
373         close FH;
374     }
375 }
376
377 # check if rename() can be used to just change case of filename
378 SKIP: {
379     skip "Works in Cygwin only if check_case is set to relaxed", 1
380       if $^O eq 'cygwin';
381
382     chdir './tmp';
383     open(fh,'>x') || die "Can't create x";
384     close(fh);
385     rename('x', 'X');
386
387     # this works on win32 only, because fs isn't casesensitive
388     ok(-e 'X', "rename working");
389
390     1 while unlink 'X';
391     chdir $wd || die "Can't cd back to $wd";
392 }
393
394 # check if rename() works on directories
395 if ($^O eq 'VMS') {
396     # must have delete access to rename a directory
397     `set file tmp.dir/protection=o:d`;
398     ok(rename('tmp.dir', 'tmp1.dir'), "rename on directories") ||
399       print "# errno: $!\n";
400 } else {
401     ok(rename('tmp', 'tmp1'), "rename on directories");
402 }
403
404 ok(-d 'tmp1', "rename on directories working");
405
406 # need to remove 'tmp' if rename() in test 28 failed!
407 END { rmdir 'tmp1'; rmdir 'tmp'; 1 while unlink "Iofs.tmp"; }