This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
30423f1d28171498e7031434810ba69d46252ab6
[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 => 34;
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 is(rename('a','b'), 1, "rename a b");
170
171 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
172  $blksize,$blocks) = stat('a');
173
174 is($ino, undef, "ino of renamed file a should be undef");
175
176 $delta = $accurate_timestamps ? 1 : 2;  # Granularity of time on the filesystem
177 chmod 0777, 'b';
178 $foo = (utime 500000000,500000000 + $delta,'b');
179
180 is($foo, 1, "utime");
181
182 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
183     $blksize,$blocks) = stat('b');
184
185 SKIP: {
186     skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare');
187
188     ok($ino,    'non-zero inode num');
189 }
190
191 SKIP: {
192     skip "filesystem atime/mtime granularity too low", 2
193       unless $accurate_timestamps;
194
195     print "# atime - $atime  mtime - $mtime  delta - $delta\n";
196     if($atime == 500000000 && $mtime == 500000000 + $delta) {
197         pass('atime');
198         pass('mtime');
199     }
200     else {
201         if ($^O =~ /\blinux\b/i) {
202             print "# Maybe stat() cannot get the correct atime, ".
203                   "as happens via NFS on linux?\n";
204             $foo = (utime 400000000,500000000 + 2*$delta,'b');
205             my ($new_atime, $new_mtime) = (stat('b'))[8,9];
206             print "# newatime - $new_atime  nemtime - $new_mtime\n";
207             if ($new_atime == $atime && $new_mtime - $mtime == $delta) {
208                 pass("atime - accounted for possible NFS/glibc2.2 bug on linux");
209                 pass("mtime - accounted for possible NFS/glibc2.2 bug on linux");
210             }
211             else {
212                 fail("atime - $atime/$new_atime $mtime/$new_mtime");
213                 fail("mtime - $atime/$new_atime $mtime/$new_mtime");
214             }
215         }
216         elsif ($^O eq 'VMS') {
217             # why is this 1 second off?
218             is( $atime, 500000001,          'atime' );
219             is( $mtime, 500000000 + $delta, 'mtime' );
220         }
221         elsif ($^O eq 'beos') {
222             SKIP: { skip "atime not updated", 1; }
223             is($mtime, 500000001, 'mtime');
224         }
225         else {
226             fail("atime");
227             fail("mtime");
228         }
229     }
230 }
231
232 is(unlink('b'), 1, "unlink b");
233
234 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
235     $blksize,$blocks) = stat('b');
236 is($ino, undef, "ino of unlinked file b should be undef");
237 unlink 'c';
238
239 chdir $wd || die "Can't cd back to $wd";
240
241 # Yet another way to look for links (perhaps those that cannot be
242 # created by perl?).  Hopefully there is an ls utility in your
243 # %PATH%. N.B. that $^O is 'cygwin' on Cygwin.
244
245 SKIP: {
246     skip "Win32/Netware specific test", 2
247       unless ($^O eq 'MSWin32') || ($^O eq 'NetWare');
248     skip "No symbolic links found to test with", 2
249       unless  `ls -l perl 2>nul` =~ /^l.*->/;
250
251     system("cp TEST TEST$$");
252     # we have to copy because e.g. GNU grep gets huffy if we have
253     # a symlink forest to another disk (it complains about too many
254     # levels of symbolic links, even if we have only two)
255     is(symlink("TEST$$","c"), 1, "symlink");
256     $foo = `grep perl c 2>&1`;
257     ok($foo, "found perl in c");
258     unlink 'c';
259     unlink("TEST$$");
260 }
261
262 unlink "Iofs.tmp";
263 open IOFSCOM, ">Iofs.tmp" or die "Could not write IOfs.tmp: $!";
264 print IOFSCOM 'helloworld';
265 close(IOFSCOM);
266
267 # TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP,
268 # as per UNIX FAQ.
269
270 SKIP: {
271 # Check truncating a closed file.
272     eval { truncate "Iofs.tmp", 5; };
273
274     skip("no truncate - $@", 8) if $@;
275
276     is(-s "Iofs.tmp", 5, "truncation to five bytes");
277
278     truncate "Iofs.tmp", 0;
279
280     ok(-z "Iofs.tmp",    "truncation to zero bytes");
281
282 #these steps are necessary to check if file is really truncated
283 #On Win95, FH is updated, but file properties aren't
284     open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
285     print FH "x\n" x 200;
286     close FH;
287
288 # Check truncating an open file.
289     open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
290
291     binmode FH;
292     select FH;
293     $| = 1;
294     select STDOUT;
295
296     {
297         use strict;
298         print FH "x\n" x 200;
299         ok(truncate(FH, 200), "fh resize to 200");
300     }
301
302     if ($needs_fh_reopen) {
303         close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
304     }
305
306     SKIP: {
307         if ($^O eq 'vos') {
308             skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5);
309         }
310
311         is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
312
313         ok(truncate(FH, 0), "fh resize to zero");
314
315         if ($needs_fh_reopen) {
316             close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
317         }
318
319         ok(-z "Iofs.tmp", "fh resize to zero working (filename check)");
320
321         close FH;
322
323         open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
324
325         binmode FH;
326         select FH;
327         $| = 1;
328         select STDOUT;
329
330         {
331             use strict;
332             print FH "x\n" x 200;
333             ok(truncate(*FH{IO}, 100), "fh resize by IO slot");
334         }
335
336         if ($needs_fh_reopen) {
337             close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
338         }
339
340         is(-s "Iofs.tmp", 100, "fh resize by IO slot working");
341
342         close FH;
343     }
344 }
345
346 # check if rename() can be used to just change case of filename
347 SKIP: {
348     skip "Works in Cygwin only if check_case is set to relaxed", 1
349       if $^O eq 'cygwin';
350
351     chdir './tmp';
352     open(fh,'>x') || die "Can't create x";
353     close(fh);
354     rename('x', 'X');
355
356     # this works on win32 only, because fs isn't casesensitive
357     ok(-e 'X', "rename working");
358
359     1 while unlink 'X';
360     chdir $wd || die "Can't cd back to $wd";
361 }
362
363 # check if rename() works on directories
364 if ($^O eq 'VMS') {
365     # must have delete access to rename a directory
366     `set file tmp.dir/protection=o:d`;
367     ok(rename('tmp.dir', 'tmp1.dir'), "rename on directories") ||
368       print "# errno: $!\n";
369 } else {
370     ok(rename('tmp', 'tmp1'), "rename on directories");
371 }
372
373 ok(-d 'tmp1', "rename on directories working");
374
375 # need to remove 'tmp' if rename() in test 28 failed!
376 END { rmdir 'tmp1'; rmdir 'tmp'; 1 while unlink "Iofs.tmp"; }