Commit | Line | Data |
8d063cd8 |
1 | #!./perl |
2 | |
ea368a7c |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
0c5d4ba3 |
6 | require "./test.pl"; |
ea368a7c |
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 |
15 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { |
16 | $wd = `cd`; |
fc8d54b0 |
17 | } |
18 | elsif ($^O eq 'VMS') { |
20dd405c |
19 | $wd = `show default`; |
fc8d54b0 |
20 | } |
21 | else { |
20dd405c |
22 | $wd = `pwd`; |
23 | } |
24 | chomp($wd); |
25 | |
0c5d4ba3 |
26 | my $has_link = $Config{d_link}; |
27 | my $accurate_timestamps = |
28 | !($^O eq 'MSWin32' || $^O eq 'NetWare' || |
29 | $^O eq 'dos' || $^O eq 'os2' || |
cd86ed9d |
30 | $^O eq 'cygwin' || $^O eq 'amigaos' || |
31 | $wd =~ m#$Config{afsroot}/# || $Is_MacOS |
20dd405c |
32 | ); |
39e571d4 |
33 | |
6b980173 |
34 | if (defined &Win32::IsWinNT && Win32::IsWinNT()) { |
0c5d4ba3 |
35 | if (Win32::FsType() eq 'NTFS') { |
20dd405c |
36 | $has_link = 1; |
37 | $accurate_timestamps = 1; |
0c5d4ba3 |
38 | } |
6b980173 |
39 | } |
40 | |
0c5d4ba3 |
41 | my $needs_fh_reopen = |
42 | $^O eq 'dos' |
43 | # Not needed on HPFS, but needed on HPFS386 ?! |
44 | || $^O eq 'os2'; |
45 | |
7a2cf369 |
46 | $needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); |
47 | |
4e51f8e4 |
48 | my $skip_mode_checks = |
49 | $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; |
50 | |
1937c63e |
51 | plan tests => 51; |
8d063cd8 |
52 | |
62a28c97 |
53 | my $tmpdir = tempfile(); |
54 | my $tmpdir1 = tempfile(); |
378cc40b |
55 | |
6d738113 |
56 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { |
62a28c97 |
57 | `rmdir /s /q $tmpdir 2>nul`; |
58 | `mkdir $tmpdir`; |
dc459aad |
59 | } |
60 | elsif ($^O eq 'VMS') { |
62a28c97 |
61 | `if f\$search("[.$tmpdir]*.*") .nes. "" then delete/nolog/noconfirm [.$tmpdir]*.*.*`; |
62 | `if f\$search("$tmpdir.dir") .nes. "" then set file/prot=o:rwed $tmpdir.dir;`; |
63 | `if f\$search("$tmpdir.dir") .nes. "" then delete/nolog/noconfirm $tmpdir.dir;`; |
64 | `create/directory [.$tmpdir]`; |
6d738113 |
65 | } |
dc459aad |
66 | elsif ($Is_MacOS) { |
62a28c97 |
67 | rmdir "$tmpdir"; mkdir "$tmpdir"; |
dc459aad |
68 | } |
6d738113 |
69 | else { |
62a28c97 |
70 | `rm -f $tmpdir 2>/dev/null; mkdir $tmpdir 2>/dev/null`; |
6d738113 |
71 | } |
0c5d4ba3 |
72 | |
62a28c97 |
73 | chdir catdir(curdir(), $tmpdir); |
0c5d4ba3 |
74 | |
b8440792 |
75 | `/bin/rm -rf a b c x` if -x '/bin/rm'; |
8d063cd8 |
76 | |
77 | umask(022); |
78 | |
20dd405c |
79 | SKIP: { |
dc459aad |
80 | skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc') || $Is_MacOS; |
20dd405c |
81 | |
82 | is((umask(0)&0777), 022, 'umask'), |
0c5d4ba3 |
83 | } |
84 | |
d5fc3e70 |
85 | open(FH,'>x') || die "Can't create x"; |
86 | close(FH); |
87 | open(FH,'>a') || die "Can't create a"; |
88 | close(FH); |
8d063cd8 |
89 | |
8268670f |
90 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
dd568cb6 |
91 | $blksize,$blocks,$a_mode); |
8268670f |
92 | |
3ed9f8f7 |
93 | SKIP: { |
0c5d4ba3 |
94 | skip("no link", 4) unless $has_link; |
8d063cd8 |
95 | |
0c5d4ba3 |
96 | ok(link('a','b'), "link a b"); |
97 | ok(link('b','c'), "link b c"); |
8d063cd8 |
98 | |
dd568cb6 |
99 | $a_mode = (stat('a'))[2]; |
100 | |
8268670f |
101 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
102 | $blksize,$blocks) = stat('c'); |
8d063cd8 |
103 | |
20dd405c |
104 | SKIP: { |
105 | skip "no nlink", 1 if $Config{dont_use_nlink}; |
106 | |
107 | is($nlink, 3, "link count of triply-linked file"); |
0c5d4ba3 |
108 | } |
ea368a7c |
109 | |
20dd405c |
110 | SKIP: { |
111 | skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos'; |
4e51f8e4 |
112 | skip "no mode checks", 1 if $skip_mode_checks; |
20dd405c |
113 | |
bbf171ae |
114 | # if ($^O eq 'cygwin') { # new files on cygwin get rwx instead of rw- |
115 | # is($mode & 0777, 0777, "mode of triply-linked file"); |
116 | # } else { |
dd568cb6 |
117 | is(sprintf("0%o", $mode & 0777), |
118 | sprintf("0%o", $a_mode & 0777), |
119 | "mode of triply-linked file"); |
bbf171ae |
120 | # } |
0c5d4ba3 |
121 | } |
122 | } |
8d063cd8 |
123 | |
2986a63f |
124 | $newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777; |
8d063cd8 |
125 | |
0c5d4ba3 |
126 | is(chmod($newmode,'a'), 1, "chmod succeeding"); |
8d063cd8 |
127 | |
0c5d4ba3 |
128 | SKIP: { |
2f3b333f |
129 | skip("no link", 7) unless $has_link; |
0c5d4ba3 |
130 | |
8268670f |
131 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
132 | $blksize,$blocks) = stat('c'); |
0c5d4ba3 |
133 | |
4e51f8e4 |
134 | SKIP: { |
135 | skip "no mode checks", 1 if $skip_mode_checks; |
136 | |
137 | is($mode & 0777, $newmode, "chmod going through"); |
138 | } |
0c5d4ba3 |
139 | |
140 | $newmode = 0700; |
6b980173 |
141 | chmod 0444, 'x'; |
142 | $newmode = 0666; |
6b980173 |
143 | |
0c5d4ba3 |
144 | is(chmod($newmode,'c','x'), 2, "chmod two files"); |
3ed9f8f7 |
145 | |
0c5d4ba3 |
146 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
147 | $blksize,$blocks) = stat('c'); |
8d063cd8 |
148 | |
4e51f8e4 |
149 | SKIP: { |
150 | skip "no mode checks", 1 if $skip_mode_checks; |
151 | |
152 | is($mode & 0777, $newmode, "chmod going through to c"); |
153 | } |
a245ea2d |
154 | |
0c5d4ba3 |
155 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
156 | $blksize,$blocks) = stat('x'); |
8d063cd8 |
157 | |
4e51f8e4 |
158 | SKIP: { |
159 | skip "no mode checks", 1 if $skip_mode_checks; |
160 | |
161 | is($mode & 0777, $newmode, "chmod going through to x"); |
162 | } |
0c5d4ba3 |
163 | |
164 | is(unlink('b','x'), 2, "unlink two files"); |
165 | |
166 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
167 | $blksize,$blocks) = stat('b'); |
168 | |
169 | is($ino, undef, "ino of removed file b should be undef"); |
170 | |
171 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
172 | $blksize,$blocks) = stat('x'); |
173 | |
174 | is($ino, undef, "ino of removed file x should be undef"); |
8268670f |
175 | } |
0c5d4ba3 |
176 | |
c4aca7d0 |
177 | SKIP: { |
178 | skip "no fchmod", 5 unless ($Config{d_fchmod} || "") eq "define"; |
179 | ok(open(my $fh, "<", "a"), "open a"); |
180 | is(chmod(0, $fh), 1, "fchmod"); |
181 | $mode = (stat "a")[2]; |
b0fdffbd |
182 | SKIP: { |
183 | skip "no mode checks", 1 if $skip_mode_checks; |
184 | is($mode & 0777, 0, "perm reset"); |
185 | } |
c4aca7d0 |
186 | is(chmod($newmode, "a"), 1, "fchmod"); |
187 | $mode = (stat $fh)[2]; |
b0fdffbd |
188 | SKIP: { |
189 | skip "no mode checks", 1 if $skip_mode_checks; |
190 | is($mode & 0777, $newmode, "perm restored"); |
191 | } |
c4aca7d0 |
192 | } |
193 | |
194 | SKIP: { |
195 | skip "no fchown", 1 unless ($Config{d_fchown} || "") eq "define"; |
196 | open(my $fh, "<", "a"); |
197 | is(chown(-1, -1, $fh), 1, "fchown"); |
198 | } |
199 | |
200 | SKIP: { |
201 | skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define"; |
202 | open(my $fh, "<", "a"); |
203 | eval { chmod(0777, $fh); }; |
204 | like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented"); |
205 | } |
206 | |
207 | SKIP: { |
208 | skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define"; |
209 | open(my $fh, "<", "a"); |
210 | eval { chown(0, 0, $fh); }; |
295d5f02 |
211 | like($@, qr/^The f?chown function is unimplemented at/, "fchown is unimplemented"); |
c4aca7d0 |
212 | } |
213 | |
8268670f |
214 | is(rename('a','b'), 1, "rename a b"); |
0c5d4ba3 |
215 | |
8268670f |
216 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
217 | $blksize,$blocks) = stat('a'); |
0c5d4ba3 |
218 | |
8268670f |
219 | is($ino, undef, "ino of renamed file a should be undef"); |
0c5d4ba3 |
220 | |
221 | $delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem |
1d825fcc |
222 | chmod 0777, 'b'; |
0c5d4ba3 |
223 | |
e96b369d |
224 | $foo = (utime 500000000,500000000 + $delta,'b'); |
0c5d4ba3 |
225 | is($foo, 1, "utime"); |
e96b369d |
226 | check_utime_result(); |
227 | |
228 | utime undef, undef, 'b'; |
229 | ($atime,$mtime) = (stat 'b')[8,9]; |
230 | print "# utime undef, undef --> $atime, $mtime\n"; |
231 | isnt($atime, 500000000, 'atime'); |
232 | isnt($mtime, 500000000 + $delta, 'mtime'); |
233 | |
234 | SKIP: { |
235 | skip "no futimes", 4 unless ($Config{d_futimes} || "") eq "define"; |
236 | open(my $fh, "<", 'b'); |
237 | $foo = (utime 500000000,500000000 + $delta, $fh); |
238 | is($foo, 1, "futime"); |
239 | check_utime_result(); |
240 | } |
0c5d4ba3 |
241 | |
e96b369d |
242 | |
243 | sub check_utime_result { |
fc8d54b0 |
244 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
245 | $blksize,$blocks) = stat('b'); |
0c5d4ba3 |
246 | |
fc8d54b0 |
247 | SKIP: { |
248 | skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare'); |
20dd405c |
249 | |
fc8d54b0 |
250 | ok($ino, 'non-zero inode num'); |
251 | } |
0c5d4ba3 |
252 | |
fc8d54b0 |
253 | SKIP: { |
254 | skip "filesystem atime/mtime granularity too low", 2 |
255 | unless $accurate_timestamps; |
20dd405c |
256 | |
fc8d54b0 |
257 | print "# atime - $atime mtime - $mtime delta - $delta\n"; |
258 | if($atime == 500000000 && $mtime == 500000000 + $delta) { |
259 | pass('atime'); |
260 | pass('mtime'); |
261 | } |
262 | else { |
263 | if ($^O =~ /\blinux\b/i) { |
264 | print "# Maybe stat() cannot get the correct atime, ". |
265 | "as happens via NFS on linux?\n"; |
266 | $foo = (utime 400000000,500000000 + 2*$delta,'b'); |
267 | my ($new_atime, $new_mtime) = (stat('b'))[8,9]; |
268 | print "# newatime - $new_atime nemtime - $new_mtime\n"; |
269 | if ($new_atime == $atime && $new_mtime - $mtime == $delta) { |
270 | pass("atime - accounted for possible NFS/glibc2.2 bug on linux"); |
271 | pass("mtime - accounted for possible NFS/glibc2.2 bug on linux"); |
272 | } |
273 | else { |
274 | fail("atime - $atime/$new_atime $mtime/$new_mtime"); |
275 | fail("mtime - $atime/$new_atime $mtime/$new_mtime"); |
276 | } |
277 | } |
278 | elsif ($^O eq 'VMS') { |
279 | # why is this 1 second off? |
280 | is( $atime, 500000001, 'atime' ); |
281 | is( $mtime, 500000000 + $delta, 'mtime' ); |
282 | } |
df00ff3b |
283 | elsif ($^O eq 'beos' || $^O eq 'haiku') { |
fc8d54b0 |
284 | SKIP: { |
285 | skip "atime not updated", 1; |
286 | } |
287 | is($mtime, 500000001, 'mtime'); |
288 | } |
289 | else { |
290 | fail("atime"); |
291 | fail("mtime"); |
292 | } |
293 | } |
0c5d4ba3 |
294 | } |
6d738113 |
295 | } |
e96b369d |
296 | |
297 | SKIP: { |
298 | skip "has futimes", 1 if ($Config{d_futimes} || "") eq "define"; |
299 | open(my $fh, "<", "b") || die; |
300 | eval { utime(undef, undef, $fh); }; |
301 | like($@, qr/^The futimes function is unimplemented at/, "futimes is unimplemented"); |
302 | } |
0c5d4ba3 |
303 | |
304 | is(unlink('b'), 1, "unlink b"); |
305 | |
8d063cd8 |
306 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
307 | $blksize,$blocks) = stat('b'); |
0c5d4ba3 |
308 | is($ino, undef, "ino of unlinked file b should be undef"); |
378cc40b |
309 | unlink 'c'; |
310 | |
311 | chdir $wd || die "Can't cd back to $wd"; |
312 | |
0c5d4ba3 |
313 | # Yet another way to look for links (perhaps those that cannot be |
314 | # created by perl?). Hopefully there is an ls utility in your |
315 | # %PATH%. N.B. that $^O is 'cygwin' on Cygwin. |
316 | |
20dd405c |
317 | SKIP: { |
318 | skip "Win32/Netware specific test", 2 |
319 | unless ($^O eq 'MSWin32') || ($^O eq 'NetWare'); |
3ed9f8f7 |
320 | skip "No symbolic links found to test with", 2 |
20dd405c |
321 | unless `ls -l perl 2>nul` =~ /^l.*->/; |
322 | |
4ba7095c |
323 | system("cp TEST TEST$$"); |
324 | # we have to copy because e.g. GNU grep gets huffy if we have |
325 | # a symlink forest to another disk (it complains about too many |
326 | # levels of symbolic links, even if we have only two) |
0c5d4ba3 |
327 | is(symlink("TEST$$","c"), 1, "symlink"); |
4ba7095c |
328 | $foo = `grep perl c 2>&1`; |
0c5d4ba3 |
329 | ok($foo, "found perl in c"); |
44a8e56a |
330 | unlink 'c'; |
4ba7095c |
331 | unlink("TEST$$"); |
378cc40b |
332 | } |
f783569b |
333 | |
62a28c97 |
334 | my $tmpfile = tempfile(); |
335 | open IOFSCOM, ">$tmpfile" or die "Could not write IOfs.tmp: $!"; |
0c5d4ba3 |
336 | print IOFSCOM 'helloworld'; |
337 | close(IOFSCOM); |
338 | |
339 | # TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP, |
340 | # as per UNIX FAQ. |
341 | |
342 | SKIP: { |
63720136 |
343 | # Check truncating a closed file. |
62a28c97 |
344 | eval { truncate $tmpfile, 5; }; |
90ddc76f |
345 | |
090bf15b |
346 | skip("no truncate - $@", 8) if $@; |
0c5d4ba3 |
347 | |
62a28c97 |
348 | is(-s $tmpfile, 5, "truncation to five bytes"); |
0c5d4ba3 |
349 | |
62a28c97 |
350 | truncate $tmpfile, 0; |
0c5d4ba3 |
351 | |
62a28c97 |
352 | ok(-z $tmpfile, "truncation to zero bytes"); |
0c5d4ba3 |
353 | |
7a2cf369 |
354 | #these steps are necessary to check if file is really truncated |
355 | #On Win95, FH is updated, but file properties aren't |
62a28c97 |
356 | open(FH, ">$tmpfile") or die "Can't create $tmpfile"; |
7a2cf369 |
357 | print FH "x\n" x 200; |
358 | close FH; |
359 | |
63720136 |
360 | # Check truncating an open file. |
62a28c97 |
361 | open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; |
0c5d4ba3 |
362 | |
363 | binmode FH; |
364 | select FH; |
365 | $| = 1; |
366 | select STDOUT; |
367 | |
368 | { |
369 | use strict; |
370 | print FH "x\n" x 200; |
371 | ok(truncate(FH, 200), "fh resize to 200"); |
62b86938 |
372 | } |
0c5d4ba3 |
373 | |
374 | if ($needs_fh_reopen) { |
62a28c97 |
375 | close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; |
0c5d4ba3 |
376 | } |
90ddc76f |
377 | |
090bf15b |
378 | SKIP: { |
379 | if ($^O eq 'vos') { |
380 | skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5); |
381 | } |
0c5d4ba3 |
382 | |
62a28c97 |
383 | is(-s $tmpfile, 200, "fh resize to 200 working (filename check)"); |
63720136 |
384 | |
090bf15b |
385 | ok(truncate(FH, 0), "fh resize to zero"); |
0c5d4ba3 |
386 | |
090bf15b |
387 | if ($needs_fh_reopen) { |
62a28c97 |
388 | close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; |
090bf15b |
389 | } |
0c5d4ba3 |
390 | |
62a28c97 |
391 | ok(-z $tmpfile, "fh resize to zero working (filename check)"); |
7a2cf369 |
392 | |
090bf15b |
393 | close FH; |
394 | |
62a28c97 |
395 | open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; |
090bf15b |
396 | |
397 | binmode FH; |
398 | select FH; |
399 | $| = 1; |
400 | select STDOUT; |
401 | |
402 | { |
403 | use strict; |
404 | print FH "x\n" x 200; |
405 | ok(truncate(*FH{IO}, 100), "fh resize by IO slot"); |
406 | } |
407 | |
408 | if ($needs_fh_reopen) { |
62a28c97 |
409 | close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; |
090bf15b |
410 | } |
411 | |
62a28c97 |
412 | is(-s $tmpfile, 100, "fh resize by IO slot working"); |
090bf15b |
413 | |
414 | close FH; |
415 | } |
f783569b |
416 | } |
80252599 |
417 | |
65cb15a1 |
418 | # check if rename() can be used to just change case of filename |
20dd405c |
419 | SKIP: { |
420 | skip "Works in Cygwin only if check_case is set to relaxed", 1 |
1a36314c |
421 | if ($ENV{'CYGWIN'} && ($ENV{'CYGWIN'} =~ /check_case:(?:adjust|strict)/)); |
20dd405c |
422 | |
62a28c97 |
423 | chdir "./$tmpdir"; |
d5fc3e70 |
424 | open(FH,'>x') || die "Can't create x"; |
425 | close(FH); |
0c5d4ba3 |
426 | rename('x', 'X'); |
3ed9f8f7 |
427 | |
0c5d4ba3 |
428 | # this works on win32 only, because fs isn't casesensitive |
429 | ok(-e 'X', "rename working"); |
8268670f |
430 | |
20dd405c |
431 | 1 while unlink 'X'; |
0c5d4ba3 |
432 | chdir $wd || die "Can't cd back to $wd"; |
73077d53 |
433 | } |
65cb15a1 |
434 | |
80252599 |
435 | # check if rename() works on directories |
0c5d4ba3 |
436 | if ($^O eq 'VMS') { |
9df548ee |
437 | # must have delete access to rename a directory |
62a28c97 |
438 | `set file $tmpdir.dir/protection=o:d`; |
7aa55bb4 |
439 | ok(rename("$tmpdir.dir", "$tmpdir1.dir"), "rename on directories") || |
20dd405c |
440 | print "# errno: $!\n"; |
fc8d54b0 |
441 | } |
442 | else { |
62a28c97 |
443 | ok(rename($tmpdir, $tmpdir1), "rename on directories"); |
6d738113 |
444 | } |
0c5d4ba3 |
445 | |
62a28c97 |
446 | ok(-d $tmpdir1, "rename on directories working"); |
80252599 |
447 | |
1937c63e |
448 | { |
449 | # Change 26011: Re: A surprising segfault |
450 | # to make sure only that these obfuscated sentences will not crash. |
451 | |
452 | map chmod(+()), ('')x68; |
453 | ok(1, "extend sp in pp_chmod"); |
454 | |
455 | map chown(+()), ('')x68; |
456 | ok(1, "extend sp in pp_chown"); |
457 | } |
458 | |
62a28c97 |
459 | # need to remove $tmpdir if rename() in test 28 failed! |
460 | END { rmdir $tmpdir1; rmdir $tmpdir; } |