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