Commit | Line | Data |
8d063cd8 |
1 | #!./perl |
2 | |
79072805 |
3 | # $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $ |
8d063cd8 |
4 | |
ea368a7c |
5 | BEGIN { |
6 | chdir 't' if -d 't'; |
20822f61 |
7 | @INC = '../lib'; |
0c5d4ba3 |
8 | require "./test.pl"; |
ea368a7c |
9 | } |
10 | |
11 | use Config; |
12 | |
6d738113 |
13 | my $Is_VMSish = ($^O eq 'VMS'); |
0c5d4ba3 |
14 | |
15 | my $has_link = $Config{d_link}; |
16 | my $accurate_timestamps = |
17 | !($^O eq 'MSWin32' || $^O eq 'NetWare' || |
18 | $^O eq 'dos' || $^O eq 'os2' || |
19 | $^O eq 'mint' || $^O eq 'cygwin'); |
39e571d4 |
20 | |
6b980173 |
21 | if (defined &Win32::IsWinNT && Win32::IsWinNT()) { |
0c5d4ba3 |
22 | if (Win32::FsType() eq 'NTFS') { |
23 | $has_link = 1; |
24 | $accurate_timestamps = 1; |
25 | } |
6b980173 |
26 | } |
27 | |
0c5d4ba3 |
28 | my $needs_fh_reopen = |
29 | $^O eq 'dos' |
30 | # Not needed on HPFS, but needed on HPFS386 ?! |
31 | || $^O eq 'os2'; |
32 | |
33 | plan tests => 31; |
8d063cd8 |
34 | |
0c5d4ba3 |
35 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { |
36 | $wd = `cd`; |
37 | } elsif ($^O eq 'VMS') { |
38 | $wd = `show default`; |
39 | } else { |
40 | $wd = `pwd`; |
41 | } |
42 | chomp($wd); |
378cc40b |
43 | |
6d738113 |
44 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { |
45 | `rmdir /s /q tmp 2>nul`; |
46 | `mkdir tmp`; |
0c5d4ba3 |
47 | } elsif ($^O eq 'VMS') { |
6d738113 |
48 | `if f\$search("[.tmp]*.*") .nes. "" then delete/nolog/noconfirm [.tmp]*.*.*`; |
49 | `if f\$search("tmp.dir") .nes. "" then delete/nolog/noconfirm tmp.dir;`; |
50 | `create/directory [.tmp]`; |
51 | } |
52 | else { |
53 | `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; |
54 | } |
0c5d4ba3 |
55 | |
378cc40b |
56 | chdir './tmp'; |
0c5d4ba3 |
57 | |
b8440792 |
58 | `/bin/rm -rf a b c x` if -x '/bin/rm'; |
8d063cd8 |
59 | |
60 | umask(022); |
61 | |
0c5d4ba3 |
62 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { |
63 | pass("Skip - bogus umask"); |
64 | } elsif ((umask(0)&0777) == 022) { |
65 | pass("umask"); |
66 | } else { |
67 | fail("umask"); |
68 | } |
69 | |
8d063cd8 |
70 | open(fh,'>x') || die "Can't create x"; |
71 | close(fh); |
72 | open(fh,'>a') || die "Can't create a"; |
73 | close(fh); |
74 | |
0c5d4ba3 |
75 | SKIP: { |
76 | skip("no link", 4) unless $has_link; |
8d063cd8 |
77 | |
0c5d4ba3 |
78 | ok(link('a','b'), "link a b"); |
79 | ok(link('b','c'), "link b c"); |
8d063cd8 |
80 | |
0c5d4ba3 |
81 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
82 | $blksize,$blocks) = stat('c'); |
8d063cd8 |
83 | |
0c5d4ba3 |
84 | if ($Config{dont_use_nlink}) { |
85 | pass("Skip - dont_use_nlink"); |
86 | } else { |
87 | is($nlink, 3, "link count of triply-linked file"); |
88 | } |
ea368a7c |
89 | |
0c5d4ba3 |
90 | if ($^O eq 'amigaos') { |
91 | pass("Skip - hard links are not that hard in $^O"); |
92 | } else { |
93 | is($mode & 0777, 0666, "mode of triply-linked file"); |
94 | } |
95 | } |
8d063cd8 |
96 | |
2986a63f |
97 | $newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777; |
8d063cd8 |
98 | |
0c5d4ba3 |
99 | is(chmod($newmode,'a'), 1, "chmod succeeding"); |
8d063cd8 |
100 | |
0c5d4ba3 |
101 | SKIP: { |
102 | skip("no link", 9) unless $has_link; |
103 | |
104 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
105 | $blksize,$blocks) = stat('c'); |
106 | |
107 | is($mode & 0777, $newmode, "chmod going through"); |
108 | |
109 | $newmode = 0700; |
6b980173 |
110 | chmod 0444, 'x'; |
111 | $newmode = 0666; |
6b980173 |
112 | |
0c5d4ba3 |
113 | is(chmod($newmode,'c','x'), 2, "chmod two files"); |
114 | |
115 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
116 | $blksize,$blocks) = stat('c'); |
8d063cd8 |
117 | |
0c5d4ba3 |
118 | is($mode & 0777, $newmode, "chmod going through to c"); |
a245ea2d |
119 | |
0c5d4ba3 |
120 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
121 | $blksize,$blocks) = stat('x'); |
8d063cd8 |
122 | |
0c5d4ba3 |
123 | is($mode & 0777, $newmode, "chmod going through to x"); |
124 | |
125 | is(unlink('b','x'), 2, "unlink two files"); |
126 | |
127 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
128 | $blksize,$blocks) = stat('b'); |
129 | |
130 | is($ino, undef, "ino of removed file b should be undef"); |
131 | |
132 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
133 | $blksize,$blocks) = stat('x'); |
134 | |
135 | is($ino, undef, "ino of removed file x should be undef"); |
136 | |
137 | # Assumed that if link() exists, so does rename(). |
138 | is(rename('a','b'), 1, "rename a b"); |
139 | |
140 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
141 | $blksize,$blocks) = stat('a'); |
142 | |
143 | is($ino, undef, "ino of renamed file a should be undef"); |
144 | } |
145 | |
146 | $delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem |
1d825fcc |
147 | chmod 0777, 'b'; |
a245ea2d |
148 | $foo = (utime 500000000,500000000 + $delta,'b'); |
0c5d4ba3 |
149 | |
150 | is($foo, 1, "utime"); |
151 | |
8d063cd8 |
152 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
153 | $blksize,$blocks) = stat('b'); |
0c5d4ba3 |
154 | |
155 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { |
156 | pass("Skip - bogus (stat)[1]\n"); |
157 | } elsif ($ino) { |
158 | pass("non-zero ino $ino"); |
159 | } else { |
160 | fail("zero ino"); |
161 | } |
162 | |
163 | if ($wd =~ m#$Config{'afsroot'}/# || |
164 | $^O eq 'amigaos' || |
165 | $^O eq 'dos' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'cygwin') { |
166 | fail("Skip - granularity of the atime/mtime"); |
167 | } elsif ($atime == 500000000 && $mtime == 500000000 + $delta) { |
168 | pass("atime/mtime"); |
169 | } elsif ($^O =~ /\blinux\b/i) { |
da93fe49 |
170 | # Maybe stat() cannot get the correct atime, as happens via NFS on linux? |
171 | $foo = (utime 400000000,500000000 + 2*$delta,'b'); |
172 | my ($new_atime, $new_mtime) = (stat('b'))[8,9]; |
0c5d4ba3 |
173 | if ($new_atime == $atime && $new_mtime - $mtime == $delta) { |
174 | pass("atime/mtime - accounted for possible NFS/glibc2.2 bug on linux"); |
175 | } else { |
176 | fail("atime mtime - $atime/$new_atime $mtime/$new_mtime"); |
177 | } |
178 | } elsif ($^O eq 'VMS') { |
179 | if ($atime == 500000001 && $mtime == 500000000 + $delta) { |
180 | pass("atime/mtime"); |
181 | } else { |
182 | fail("atime $atime mtime $mtime"); |
183 | } |
184 | } elsif ($^O eq 'beos') { |
185 | if ($atime == 500000001) { |
186 | pass("atime (mtime not updated)"); |
187 | } else { |
188 | fail("atime $atime (mtime not updated)"); |
189 | } |
190 | } else { |
191 | fail("atime/mtime"); |
6d738113 |
192 | } |
0c5d4ba3 |
193 | |
194 | is(unlink('b'), 1, "unlink b"); |
195 | |
8d063cd8 |
196 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
197 | $blksize,$blocks) = stat('b'); |
0c5d4ba3 |
198 | is($ino, undef, "ino of unlinked file b should be undef"); |
378cc40b |
199 | unlink 'c'; |
200 | |
201 | chdir $wd || die "Can't cd back to $wd"; |
202 | |
8d063cd8 |
203 | unlink 'c'; |
0c5d4ba3 |
204 | |
205 | # Yet another way to look for links (perhaps those that cannot be |
206 | # created by perl?). Hopefully there is an ls utility in your |
207 | # %PATH%. N.B. that $^O is 'cygwin' on Cygwin. |
208 | |
209 | if ((($^O eq 'MSWin32') || ($^O eq 'NetWare')) && |
210 | `ls -l perl 2>nul` =~ /^l.*->/) { |
68dc0745 |
211 | # we have symbolic links |
4ba7095c |
212 | system("cp TEST TEST$$"); |
213 | # we have to copy because e.g. GNU grep gets huffy if we have |
214 | # a symlink forest to another disk (it complains about too many |
215 | # levels of symbolic links, even if we have only two) |
0c5d4ba3 |
216 | is(symlink("TEST$$","c"), 1, "symlink"); |
4ba7095c |
217 | $foo = `grep perl c 2>&1`; |
0c5d4ba3 |
218 | ok($foo, "found perl in c"); |
44a8e56a |
219 | unlink 'c'; |
4ba7095c |
220 | unlink("TEST$$"); |
378cc40b |
221 | } |
222 | else { |
7054c437 |
223 | if ( ($^O eq 'MSWin32') || ($^O eq 'NetWare') ) { |
0c5d4ba3 |
224 | pass("Skip - no symbolic links") for 1..2; |
7054c437 |
225 | } |
226 | else { |
0c5d4ba3 |
227 | pass("Skip - '$^O' is neither 'MSWin32' nor 'NetWare'") for 1..2; |
7054c437 |
228 | } |
378cc40b |
229 | } |
f783569b |
230 | |
f783569b |
231 | unlink "Iofs.tmp"; |
0c5d4ba3 |
232 | open IOFSCOM, ">Iofs.tmp" or die "Could not write IOfs.tmp: $!"; |
233 | print IOFSCOM 'helloworld'; |
234 | close(IOFSCOM); |
235 | |
236 | # TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP, |
237 | # as per UNIX FAQ. |
238 | |
239 | SKIP: { |
240 | eval { truncate "Iofs.tmp", 5; }; |
241 | |
242 | skip("no truncate - $@", 4) if $@; |
243 | |
244 | is(-s "Iofs.tmp", 5, "truncation to five bytes"); |
245 | |
246 | truncate "Iofs.tmp", 0; |
247 | |
248 | ok(-z "Iofs.tmp", "truncation to zero bytes"); |
249 | |
250 | open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp"; |
251 | |
252 | binmode FH; |
253 | select FH; |
254 | $| = 1; |
255 | select STDOUT; |
256 | |
257 | { |
258 | use strict; |
259 | print FH "x\n" x 200; |
260 | ok(truncate(FH, 200), "fh resize to 200"); |
62b86938 |
261 | } |
0c5d4ba3 |
262 | |
263 | if ($needs_fh_reopen) { |
264 | close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; |
265 | } |
266 | |
267 | is(-s "Iofs.tmp", 200, "fh resize to 200 working"); |
268 | |
269 | ok(truncate(FH, 0), "fh resize to zero"); |
270 | |
271 | if ($needs_fh_reopen) { |
272 | close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; |
273 | } |
274 | |
275 | ok(-z "Iofs.tmp", "fh resize to zero working"); |
276 | |
277 | close FH; |
f783569b |
278 | } |
80252599 |
279 | |
65cb15a1 |
280 | # check if rename() can be used to just change case of filename |
73077d53 |
281 | if ($^O eq 'cygwin') { |
0c5d4ba3 |
282 | pass("Skip - works in $^O only if check_case is set to relaxed"); |
73077d53 |
283 | } else { |
0c5d4ba3 |
284 | chdir './tmp'; |
285 | open(fh,'>x') || die "Can't create x"; |
286 | close(fh); |
287 | rename('x', 'X'); |
288 | |
289 | # this works on win32 only, because fs isn't casesensitive |
290 | ok(-e 'X', "rename working"); |
291 | |
292 | unlink 'X'; |
293 | chdir $wd || die "Can't cd back to $wd"; |
73077d53 |
294 | } |
65cb15a1 |
295 | |
80252599 |
296 | # check if rename() works on directories |
0c5d4ba3 |
297 | if ($^O eq 'VMS') { |
9df548ee |
298 | # must have delete access to rename a directory |
299 | `set file tmp.dir/protection=o:d`; |
0c5d4ba3 |
300 | ok(rename('tmp.dir', 'tmp1.dir'), "rename on directories"); |
301 | } else { |
302 | ok(rename('tmp', 'tmp1'), "rename on directories"); |
6d738113 |
303 | } |
0c5d4ba3 |
304 | |
305 | ok(-d 'tmp1', "rename on directories working"); |
80252599 |
306 | |
73077d53 |
307 | # need to remove 'tmp' if rename() in test 28 failed! |
308 | END { rmdir 'tmp1'; rmdir 'tmp'; unlink "Iofs.tmp"; } |