Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
ea368a7c CS |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
0c5d4ba3 | 6 | require "./test.pl"; |
ea368a7c CS |
7 | } |
8 | ||
9 | use Config; | |
dc459aad | 10 | use File::Spec::Functions; |
ea368a7c | 11 | |
dc459aad | 12 | my $Is_MacOS = ($^O eq 'MacOS'); |
6d738113 | 13 | my $Is_VMSish = ($^O eq 'VMS'); |
0c5d4ba3 | 14 | |
20dd405c MS |
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 | ||
0c5d4ba3 JH |
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' || | |
20dd405c | 28 | $^O eq 'mint' || $^O eq 'cygwin' || |
dc459aad JH |
29 | $^O eq 'amigaos' || $wd =~ m#$Config{afsroot}/# || |
30 | $Is_MacOS | |
20dd405c | 31 | ); |
39e571d4 | 32 | |
6b980173 | 33 | if (defined &Win32::IsWinNT && Win32::IsWinNT()) { |
0c5d4ba3 | 34 | if (Win32::FsType() eq 'NTFS') { |
20dd405c MS |
35 | $has_link = 1; |
36 | $accurate_timestamps = 1; | |
0c5d4ba3 | 37 | } |
6b980173 JD |
38 | } |
39 | ||
0c5d4ba3 JH |
40 | my $needs_fh_reopen = |
41 | $^O eq 'dos' | |
42 | # Not needed on HPFS, but needed on HPFS386 ?! | |
43 | || $^O eq 'os2'; | |
44 | ||
7a2cf369 NK |
45 | $needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); |
46 | ||
4e51f8e4 SR |
47 | my $skip_mode_checks = |
48 | $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; | |
49 | ||
090bf15b | 50 | plan tests => 34; |
8d063cd8 | 51 | |
378cc40b | 52 | |
6d738113 PP |
53 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { |
54 | `rmdir /s /q tmp 2>nul`; | |
55 | `mkdir tmp`; | |
dc459aad JH |
56 | } |
57 | elsif ($^O eq 'VMS') { | |
6d738113 PP |
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 | } | |
dc459aad JH |
62 | elsif ($Is_MacOS) { |
63 | rmdir "tmp"; mkdir "tmp"; | |
64 | } | |
6d738113 PP |
65 | else { |
66 | `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; | |
67 | } | |
0c5d4ba3 | 68 | |
dc459aad | 69 | chdir catdir(curdir(), 'tmp'); |
0c5d4ba3 | 70 | |
b8440792 | 71 | `/bin/rm -rf a b c x` if -x '/bin/rm'; |
8d063cd8 LW |
72 | |
73 | umask(022); | |
74 | ||
20dd405c | 75 | SKIP: { |
dc459aad | 76 | skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc') || $Is_MacOS; |
20dd405c MS |
77 | |
78 | is((umask(0)&0777), 022, 'umask'), | |
0c5d4ba3 JH |
79 | } |
80 | ||
8d063cd8 LW |
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 | ||
8268670f JH |
86 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
87 | $blksize,$blocks); | |
88 | ||
3ed9f8f7 | 89 | SKIP: { |
0c5d4ba3 | 90 | skip("no link", 4) unless $has_link; |
8d063cd8 | 91 | |
0c5d4ba3 JH |
92 | ok(link('a','b'), "link a b"); |
93 | ok(link('b','c'), "link b c"); | |
8d063cd8 | 94 | |
8268670f JH |
95 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
96 | $blksize,$blocks) = stat('c'); | |
8d063cd8 | 97 | |
20dd405c MS |
98 | SKIP: { |
99 | skip "no nlink", 1 if $Config{dont_use_nlink}; | |
100 | ||
101 | is($nlink, 3, "link count of triply-linked file"); | |
0c5d4ba3 | 102 | } |
ea368a7c | 103 | |
20dd405c MS |
104 | SKIP: { |
105 | skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos'; | |
4e51f8e4 | 106 | skip "no mode checks", 1 if $skip_mode_checks; |
20dd405c | 107 | |
bbf171ae GH |
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 { | |
4e51f8e4 | 111 | is($mode & 0777, 0666, "mode of triply-linked file"); |
bbf171ae | 112 | # } |
0c5d4ba3 JH |
113 | } |
114 | } | |
8d063cd8 | 115 | |
2986a63f | 116 | $newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777; |
8d063cd8 | 117 | |
0c5d4ba3 | 118 | is(chmod($newmode,'a'), 1, "chmod succeeding"); |
8d063cd8 | 119 | |
0c5d4ba3 | 120 | SKIP: { |
2f3b333f | 121 | skip("no link", 7) unless $has_link; |
0c5d4ba3 | 122 | |
8268670f JH |
123 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
124 | $blksize,$blocks) = stat('c'); | |
0c5d4ba3 | 125 | |
4e51f8e4 SR |
126 | SKIP: { |
127 | skip "no mode checks", 1 if $skip_mode_checks; | |
128 | ||
129 | is($mode & 0777, $newmode, "chmod going through"); | |
130 | } | |
0c5d4ba3 JH |
131 | |
132 | $newmode = 0700; | |
6b980173 JD |
133 | chmod 0444, 'x'; |
134 | $newmode = 0666; | |
6b980173 | 135 | |
0c5d4ba3 | 136 | is(chmod($newmode,'c','x'), 2, "chmod two files"); |
3ed9f8f7 | 137 | |
0c5d4ba3 JH |
138 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
139 | $blksize,$blocks) = stat('c'); | |
8d063cd8 | 140 | |
4e51f8e4 SR |
141 | SKIP: { |
142 | skip "no mode checks", 1 if $skip_mode_checks; | |
143 | ||
144 | is($mode & 0777, $newmode, "chmod going through to c"); | |
145 | } | |
a245ea2d | 146 | |
0c5d4ba3 JH |
147 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
148 | $blksize,$blocks) = stat('x'); | |
8d063cd8 | 149 | |
4e51f8e4 SR |
150 | SKIP: { |
151 | skip "no mode checks", 1 if $skip_mode_checks; | |
152 | ||
153 | is($mode & 0777, $newmode, "chmod going through to x"); | |
154 | } | |
0c5d4ba3 JH |
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"); | |
8268670f | 167 | } |
0c5d4ba3 | 168 | |
8268670f | 169 | is(rename('a','b'), 1, "rename a b"); |
0c5d4ba3 | 170 | |
8268670f JH |
171 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
172 | $blksize,$blocks) = stat('a'); | |
0c5d4ba3 | 173 | |
8268670f | 174 | is($ino, undef, "ino of renamed file a should be undef"); |
0c5d4ba3 JH |
175 | |
176 | $delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem | |
1d825fcc | 177 | chmod 0777, 'b'; |
a245ea2d | 178 | $foo = (utime 500000000,500000000 + $delta,'b'); |
0c5d4ba3 JH |
179 | |
180 | is($foo, 1, "utime"); | |
181 | ||
8d063cd8 LW |
182 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
183 | $blksize,$blocks) = stat('b'); | |
0c5d4ba3 | 184 | |
20dd405c MS |
185 | SKIP: { |
186 | skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare'); | |
187 | ||
188 | ok($ino, 'non-zero inode num'); | |
0c5d4ba3 JH |
189 | } |
190 | ||
20dd405c | 191 | SKIP: { |
3ed9f8f7 | 192 | skip "filesystem atime/mtime granularity too low", 2 |
20dd405c MS |
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'); | |
0c5d4ba3 | 199 | } |
20dd405c MS |
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) { | |
3ed9f8f7 NIS |
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 | } | |
20dd405c | 211 | else { |
3ed9f8f7 NIS |
212 | fail("atime - $atime/$new_atime $mtime/$new_mtime"); |
213 | fail("mtime - $atime/$new_atime $mtime/$new_mtime"); | |
20dd405c | 214 | } |
3ed9f8f7 | 215 | } |
20dd405c MS |
216 | elsif ($^O eq 'VMS') { |
217 | # why is this 1 second off? | |
218 | is( $atime, 500000001, 'atime' ); | |
219 | is( $mtime, 500000000 + $delta, 'mtime' ); | |
3ed9f8f7 | 220 | } |
20dd405c MS |
221 | elsif ($^O eq 'beos') { |
222 | SKIP: { skip "atime not updated", 1; } | |
223 | is($mtime, 500000001, 'mtime'); | |
3ed9f8f7 | 224 | } |
20dd405c MS |
225 | else { |
226 | fail("atime"); | |
227 | fail("mtime"); | |
228 | } | |
0c5d4ba3 | 229 | } |
6d738113 | 230 | } |
0c5d4ba3 JH |
231 | |
232 | is(unlink('b'), 1, "unlink b"); | |
233 | ||
8d063cd8 LW |
234 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
235 | $blksize,$blocks) = stat('b'); | |
0c5d4ba3 | 236 | is($ino, undef, "ino of unlinked file b should be undef"); |
378cc40b LW |
237 | unlink 'c'; |
238 | ||
239 | chdir $wd || die "Can't cd back to $wd"; | |
240 | ||
0c5d4ba3 JH |
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 | ||
20dd405c MS |
245 | SKIP: { |
246 | skip "Win32/Netware specific test", 2 | |
247 | unless ($^O eq 'MSWin32') || ($^O eq 'NetWare'); | |
3ed9f8f7 | 248 | skip "No symbolic links found to test with", 2 |
20dd405c MS |
249 | unless `ls -l perl 2>nul` =~ /^l.*->/; |
250 | ||
4ba7095c JH |
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) | |
0c5d4ba3 | 255 | is(symlink("TEST$$","c"), 1, "symlink"); |
4ba7095c | 256 | $foo = `grep perl c 2>&1`; |
0c5d4ba3 | 257 | ok($foo, "found perl in c"); |
44a8e56a | 258 | unlink 'c'; |
4ba7095c | 259 | unlink("TEST$$"); |
378cc40b | 260 | } |
f783569b | 261 | |
f783569b | 262 | unlink "Iofs.tmp"; |
0c5d4ba3 JH |
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: { | |
63720136 | 271 | # Check truncating a closed file. |
0c5d4ba3 | 272 | eval { truncate "Iofs.tmp", 5; }; |
90ddc76f | 273 | |
090bf15b | 274 | skip("no truncate - $@", 8) if $@; |
0c5d4ba3 JH |
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 | ||
7a2cf369 NK |
282 | #these steps are necessary to check if file is really truncated |
283 | #On Win95, FH is updated, but file properties aren't | |
0c5d4ba3 | 284 | open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp"; |
7a2cf369 NK |
285 | print FH "x\n" x 200; |
286 | close FH; | |
287 | ||
63720136 PG |
288 | # Check truncating an open file. |
289 | open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending"; | |
0c5d4ba3 JH |
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"); | |
62b86938 | 300 | } |
0c5d4ba3 JH |
301 | |
302 | if ($needs_fh_reopen) { | |
303 | close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; | |
304 | } | |
90ddc76f | 305 | |
090bf15b SR |
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 | } | |
0c5d4ba3 | 310 | |
090bf15b | 311 | is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)"); |
63720136 | 312 | |
090bf15b | 313 | ok(truncate(FH, 0), "fh resize to zero"); |
0c5d4ba3 | 314 | |
090bf15b SR |
315 | if ($needs_fh_reopen) { |
316 | close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; | |
317 | } | |
0c5d4ba3 | 318 | |
090bf15b | 319 | ok(-z "Iofs.tmp", "fh resize to zero working (filename check)"); |
7a2cf369 | 320 | |
090bf15b SR |
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 | } | |
f783569b | 344 | } |
80252599 | 345 | |
65cb15a1 | 346 | # check if rename() can be used to just change case of filename |
20dd405c MS |
347 | SKIP: { |
348 | skip "Works in Cygwin only if check_case is set to relaxed", 1 | |
349 | if $^O eq 'cygwin'; | |
350 | ||
0c5d4ba3 JH |
351 | chdir './tmp'; |
352 | open(fh,'>x') || die "Can't create x"; | |
353 | close(fh); | |
354 | rename('x', 'X'); | |
3ed9f8f7 | 355 | |
0c5d4ba3 JH |
356 | # this works on win32 only, because fs isn't casesensitive |
357 | ok(-e 'X', "rename working"); | |
8268670f | 358 | |
20dd405c | 359 | 1 while unlink 'X'; |
0c5d4ba3 | 360 | chdir $wd || die "Can't cd back to $wd"; |
73077d53 | 361 | } |
65cb15a1 | 362 | |
80252599 | 363 | # check if rename() works on directories |
0c5d4ba3 | 364 | if ($^O eq 'VMS') { |
9df548ee CB |
365 | # must have delete access to rename a directory |
366 | `set file tmp.dir/protection=o:d`; | |
20dd405c MS |
367 | ok(rename('tmp.dir', 'tmp1.dir'), "rename on directories") || |
368 | print "# errno: $!\n"; | |
0c5d4ba3 JH |
369 | } else { |
370 | ok(rename('tmp', 'tmp1'), "rename on directories"); | |
6d738113 | 371 | } |
0c5d4ba3 JH |
372 | |
373 | ok(-d 'tmp1', "rename on directories working"); | |
80252599 | 374 | |
73077d53 | 375 | # need to remove 'tmp' if rename() in test 28 failed! |
4e7ee149 | 376 | END { rmdir 'tmp1'; rmdir 'tmp'; 1 while unlink "Iofs.tmp"; } |