This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utime() updates only the mtime in BeOS.
[perl5.git] / t / io / fs.t
CommitLineData
8d063cd8
LW
1#!./perl
2
79072805 3# $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $
8d063cd8 4
ea368a7c
CS
5BEGIN {
6 chdir 't' if -d 't';
20822f61 7 @INC = '../lib';
ea368a7c
CS
8}
9
10use Config;
11
6d738113 12my $Is_VMSish = ($^O eq 'VMS');
2986a63f 13$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'dos' or
c9ff6e92
JH
14 $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin' or
15 $^O eq 'mpeix');
39e571d4 16
6b980173
JD
17if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
18 $Is_Dosish = '' if Win32::FsType() eq 'NTFS';
19}
20
65cb15a1 21print "1..29\n";
8d063cd8 22
6d738113 23$wd = ((($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? `cd` : ($Is_VMSish) ? `show default` : `pwd`);
378cc40b
LW
24chop($wd);
25
6d738113
PP
26if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
27 `rmdir /s /q tmp 2>nul`;
28 `mkdir tmp`;
29}
30elsif ($Is_VMSish) {
31 `if f\$search("[.tmp]*.*") .nes. "" then delete/nolog/noconfirm [.tmp]*.*.*`;
32 `if f\$search("tmp.dir") .nes. "" then delete/nolog/noconfirm tmp.dir;`;
33 `create/directory [.tmp]`;
34}
35else {
36 `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
37}
378cc40b 38chdir './tmp';
b8440792 39`/bin/rm -rf a b c x` if -x '/bin/rm';
8d063cd8
LW
40
41umask(022);
42
2986a63f 43if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { print "ok 1 # skipped: bogus umask()\n"; }
80252599 44elsif ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";}
8d063cd8
LW
45open(fh,'>x') || die "Can't create x";
46close(fh);
47open(fh,'>a') || die "Can't create a";
48close(fh);
49
6d738113 50if ($Is_Dosish || $Is_VMSish) {print "ok 2 # skipped: no link\n";}
a245ea2d
IZ
51elsif (eval {link('a','b')}) {print "ok 2\n";}
52else {print "not ok 2\n";}
8d063cd8 53
6d738113 54if ($Is_Dosish || $Is_VMSish) {print "ok 3 # skipped: no link\n";}
a245ea2d
IZ
55elsif (eval {link('b','c')}) {print "ok 3\n";}
56else {print "not ok 3\n";}
8d063cd8
LW
57
58($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
59 $blksize,$blocks) = stat('c');
60
6d738113 61if ($Config{dont_use_nlink} || $Is_Dosish || $Is_VMSish)
a245ea2d
IZ
62 {print "ok 4 # skipped: no link\n";}
63elsif ($nlink == 3)
64 {print "ok 4\n";}
65else {print "not ok 4\n";}
ea368a7c 66
6d738113 67if ($^O eq 'amigaos' || $Is_Dosish || $Is_VMSish)
a245ea2d
IZ
68 {print "ok 5 # skipped: no link\n";}
69elsif (($mode & 0777) == 0666)
70 {print "ok 5\n";}
71else {print "not ok 5\n";}
8d063cd8 72
2986a63f 73$newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777;
6b980173 74if ((chmod $newmode,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";}
8d063cd8
LW
75
76($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
77 $blksize,$blocks) = stat('c');
6d738113 78if ($Is_Dosish || $Is_VMSish) {print "ok 7 # skipped: no link\n";}
6b980173 79elsif (($mode & 0777) == $newmode) {print "ok 7\n";}
a245ea2d 80else {print "not ok 7\n";}
8d063cd8 81
6b980173 82$newmode = 0700;
2986a63f 83if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
6b980173
JD
84 chmod 0444, 'x';
85 $newmode = 0666;
86}
87
6d738113 88if ($Is_Dosish || $Is_VMSish) {print "ok 8 # skipped: no link\n";}
6b980173 89elsif ((chmod $newmode,'c','x') == 2) {print "ok 8\n";}
a245ea2d 90else {print "not ok 8\n";}
8d063cd8
LW
91
92($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
93 $blksize,$blocks) = stat('c');
6d738113 94if ($Is_Dosish || $Is_VMSish) {print "ok 9 # skipped: no link\n";}
6b980173 95elsif (($mode & 0777) == $newmode) {print "ok 9\n";}
a245ea2d
IZ
96else {print "not ok 9\n";}
97
8d063cd8
LW
98($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
99 $blksize,$blocks) = stat('x');
6d738113 100if ($Is_Dosish || $Is_VMSish) {print "ok 10 # skipped: no link\n";}
6b980173 101elsif (($mode & 0777) == $newmode) {print "ok 10\n";}
a245ea2d 102else {print "not ok 10\n";}
8d063cd8 103
6d738113 104if ($Is_Dosish || $Is_VMSish) {print "ok 11 # skipped: no link\n"; unlink 'b','x'; }
a245ea2d
IZ
105elsif ((unlink 'b','x') == 2) {print "ok 11\n";}
106else {print "not ok 11\n";}
8d063cd8
LW
107($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
108 $blksize,$blocks) = stat('b');
109if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";}
110($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
111 $blksize,$blocks) = stat('x');
112if ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";}
113
114if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";}
115($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
116 $blksize,$blocks) = stat('a');
117if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";}
a245ea2d 118$delta = $Is_Dosish ? 2 : 1; # Granularity of time on the filesystem
1d825fcc 119chmod 0777, 'b';
a245ea2d 120$foo = (utime 500000000,500000000 + $delta,'b');
378cc40b 121if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
8d063cd8
LW
122($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
123 $blksize,$blocks) = stat('b');
2986a63f 124if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { print "ok 17 # skipped: bogus (stat)[1]\n"; }
80252599 125elsif ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
897bbb29 126if ($wd =~ m#$Config{'afsroot'}/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'cygwin')
a245ea2d
IZ
127 {print "ok 18 # skipped: granularity of the filetime\n";}
128elsif ($atime == 500000000 && $mtime == 500000000 + $delta)
6eb13c3b 129 {print "ok 18\n";}
da93fe49
RM
130elsif ($^O =~ /\blinux\b/i) {
131 # Maybe stat() cannot get the correct atime, as happens via NFS on linux?
132 $foo = (utime 400000000,500000000 + 2*$delta,'b');
133 my ($new_atime, $new_mtime) = (stat('b'))[8,9];
134 if ($new_atime == $atime && $new_mtime - $mtime == $delta)
135 {print "ok 18 # accounted for possible NFS/glibc2.2 bug on linux\n";}
136 else
137 {print "not ok 18 $atime/$new_atime $mtime/$new_mtime\n";}
6d738113
PP
138}
139elsif ($Is_VMSish) {
140 if ($atime == 500000001 && $mtime == 500000000 + $delta)
141 {print "ok 18\n";}
142 else
143 {print "not ok 18 $atime $mtime\n";}
da93fe49 144} else
6eb13c3b 145 {print "not ok 18 $atime $mtime\n";}
8d063cd8 146
378cc40b 147if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}
8d063cd8
LW
148($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
149 $blksize,$blocks) = stat('b');
378cc40b
LW
150if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";}
151unlink 'c';
152
153chdir $wd || die "Can't cd back to $wd";
154
8d063cd8 155unlink 'c';
7054c437
PK
156# Yet another way to look for links (perhaps those that cannot be created by perl?).
157# Hopefully there is an ls utility in your %PATH%. N.B. that $^O is 'cygwin' on Cygwin.
158if ((($^O eq 'MSWin32') || ($^O eq 'NetWare')) and `ls -l perl 2>nul` =~ /^l.*->/) {
68dc0745 159 # we have symbolic links
4ba7095c
JH
160 system("cp TEST TEST$$");
161 # we have to copy because e.g. GNU grep gets huffy if we have
162 # a symlink forest to another disk (it complains about too many
163 # levels of symbolic links, even if we have only two)
164 if (symlink("TEST$$","c")) {print "ok 21\n";} else {print "not ok 21\n";}
165 $foo = `grep perl c 2>&1`;
378cc40b 166 if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}
44a8e56a 167 unlink 'c';
4ba7095c 168 unlink("TEST$$");
378cc40b
LW
169}
170else {
7054c437
PK
171 if ( ($^O eq 'MSWin32') || ($^O eq 'NetWare') ) {
172 print "ok 21 # skipped: no link\nok 22 # skipped: no link\n";
173 }
174 else {
79316e73 175 print "ok 21 # skipped: '$^O' is neither 'MSWin32' nor 'NetWare'\nok 22 # skipped: $^O is neither 'MSWin32' nor 'NetWare'\n";
7054c437 176 }
378cc40b 177}
f783569b
PP
178
179# truncate (may not be implemented everywhere)
180unlink "Iofs.tmp";
6d738113
PP
181if ($Is_VMSish) {
182 open IOFSCOM, ">Iofs.tmp" or die "Could not write IOfs.tmp: $!";
183 print IOFSCOM 'helloworld';
184 close(IOFSCOM);
185}
186else {
187 `echo helloworld > Iofs.tmp`;
188}
189#
190# Perhaps the eval would be better written with a construct such as?:
191#if (defined($Config{d_truncate}) && $Config{d_truncate} eq 'define') {
192#
f783569b 193eval { truncate "Iofs.tmp", 5; };
62b86938
A
194if ($@) {
195 if ($@ =~ /not implemented/) {
196 print "# truncate not implemented -- skipping tests 23 through 26\n";
197 for (23 .. 26) {
198 print "ok $_ # Skip: no truncate\n";
199 }
200 } else {
201 warn "io/fs before test 23: truncate dies with \$\@[$@]";
f783569b
PP
202 }
203}
204else {
62b86938
A
205 if (-s "Iofs.tmp" == 5) {
206 print "ok 23\n";
207 } else {
208 my $s = -s "Iofs.tmp";
209 printf "# -s Iofs.tmp: %s\n", defined($s) ? $s : "UNDEFINED";
210 print "not ok 23\n";
211 }
f783569b
PP
212 truncate "Iofs.tmp", 0;
213 if (-z "Iofs.tmp") {print "ok 24\n"} else {print "not ok 24\n"}
f783569b 214 open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
2f3b6ae4 215 binmode FH;
1bcfde30 216 { select FH; $| = 1; select STDOUT }
bb53490d
GS
217 {
218 use strict;
2f3b6ae4
GS
219 print FH "x\n" x 200;
220 truncate(FH, 200) or die "Can't truncate FH: $!";
bb53490d 221 }
ed344e4f
IZ
222 if ($^O eq 'dos'
223 # Not needed on HPFS, but needed on HPFS386 ?!
224 or $^O eq 'os2')
225 {
39e571d4
ML
226 close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
227 }
6d738113
PP
228 if (-s "Iofs.tmp" == 200) {
229 print "ok 25\n"
230 }
231 else {
232 my $s = -s "Iofs.tmp";
233 printf "# -s Iofs.tmp: %s\n", defined($s) ? $s : "UNDEFINED";
234 print "not ok 25\n";
235 }
f783569b 236 truncate FH, 0;
ed344e4f
IZ
237 if ($^O eq 'dos'
238 # Not needed on HPFS, but needed on HPFS386 ?!
239 or $^O eq 'os2')
240 {
39e571d4
ML
241 close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
242 }
f783569b
PP
243 if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"}
244 close FH;
245}
80252599 246
65cb15a1 247# check if rename() can be used to just change case of filename
73077d53
GH
248if ($^O eq 'cygwin') {
249 print "ok 27 # skipped: works only if check_case is set to relaxed.\n";
250} else {
251 chdir './tmp';
252 open(fh,'>x') || die "Can't create x";
253 close(fh);
254 rename('x', 'X');
255
256 # this works on win32 only, because fs isn't casesensitive
257 print 'not ' unless -e 'X';
258
259 print "ok 27\n";
260 unlink 'X';
261 chdir $wd || die "Can't cd back to $wd";
262}
65cb15a1 263
80252599 264# check if rename() works on directories
6d738113 265if ($Is_VMSish) {
9df548ee
CB
266 # must have delete access to rename a directory
267 `set file tmp.dir/protection=o:d`;
6d738113
PP
268 rename 'tmp.dir', 'tmp1.dir' or print "not ";
269}
270else {
271 rename 'tmp', 'tmp1' or print "not ";
272}
80252599 273print "ok 28\n";
65cb15a1
GS
274-d 'tmp1' or print "not ";
275print "ok 29\n";
80252599 276
73077d53
GH
277# need to remove 'tmp' if rename() in test 28 failed!
278END { rmdir 'tmp1'; rmdir 'tmp'; unlink "Iofs.tmp"; }