567652c98ecf071817a69f5b843c67ec43c246e9
[perl.git] / ext / Win32API / File / t / file.t
1 #!/usr/bin/perl -w
2 # Before `make install' is performed this script should be runnable with
3 # `make test'. After `make install' it should work as `perl test.pl'
4
5 ######################### We start with some black magic to print on failure.
6
7 BEGIN {
8     $|= 1;
9
10     # when building perl, skip this test if Win32API::File isn't being built
11     if ( $ENV{PERL_CORE} ) {
12         require Config;
13         if ( $Config::Config{extensions} !~ m:(?<!\S)Win32API/File(?!\S): ) {
14             print "1..0 # Skip Win32API::File extension not built\n";
15             exit();
16         }
17     }
18
19     print "1..267\n";
20 }
21 END {print "not ok 1\n" unless $loaded;}
22
23 # Win32API::File does an implicit "require Win32", but
24 # the ../lib directory in @INC will no longer work once
25 # we chdir() into the TEMP directory.
26
27 use Win32;
28 use File::Spec;
29 use Carp;
30 use Carp::Heavy;
31
32 use Win32API::File qw(:ALL);
33 $loaded = 1;
34 print "ok 1\n";
35
36 ######################### End of black magic.
37
38 $test= 1;
39
40 use strict qw(subs);
41
42 $temp= File::Spec->tmpdir();
43 $dir= "W32ApiF.tmp";
44
45 $ENV{WINDIR} = $ENV{SYSTEMROOT} if not exists $ENV{WINDIR};
46
47 chdir( $temp )
48   or  die "# Can't cd to temp directory, $temp: $!\n";
49 $tempdir = File::Spec->catdir($temp,$dir);
50 if(  -d $dir  ) {
51     print "# deleting ",File::Spec->catdir($temp,$dir,'*'),"\n" if glob "$dir/*";
52
53     for (glob "$dir/*") {
54         chmod 0777, $_;
55         unlink $_;
56     }
57     rmdir $dir or die "Could not rmdir $dir: $!";
58 }
59 mkdir( $dir, 0777 )
60   or  die "# Can't create temp dir, $tempdir: $!\n";
61 print "# chdir $tempdir\n";
62 chdir( $dir )
63   or  die "# Can't cd to my dir, $tempdir: $!\n";
64 $h1= createFile( "ReadOnly.txt", "r", { Attributes=>"r" } );
65 $ok=  ! $h1  &&  Win32API::File::_fileLastError() == 2; # could not find the file
66 $ok or print "# ","".fileLastError(),"\n";
67 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 2
68 if(  ! $ok  ) {   CloseHandle($h1);   unlink("ReadOnly.txt");   }
69
70 $ok= $h1= createFile( "ReadOnly.txt", "wcn", { Attributes=>"r" } );
71 $ok or print "# ",fileLastError(),"\n";
72 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 3
73
74 $ok= WriteFile( $h1, "Original text\n", 0, [], [] );
75 $ok or print "# ",fileLastError(),"\n";
76 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 4
77
78 $h2= createFile( "ReadOnly.txt", "rcn" );
79 $ok= ! $h2  &&  Win32API::File::_fileLastError() == 80; # file exists
80 $ok or print "# ",fileLastError(),"\n";
81 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 5
82 if(  ! $ok  ) {   CloseHandle($h2);   }
83
84 $h2= createFile( "ReadOnly.txt", "rwke" );
85 $ok= ! $h2  &&  Win32API::File::_fileLastError() == 5; # access is denied
86 $ok or print "# ",fileLastError(),"\n";
87 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 6
88 if(  ! $ok  ) {   CloseHandle($h2);   }
89
90 $ok= $h2= createFile( "ReadOnly.txt", "r" );
91 $ok or print "# ",fileLastError(),"\n";
92 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 7
93
94 $ok= SetFilePointer( $h1, length("Original"), [], FILE_BEGIN );
95 $ok or print "# ",fileLastError(),"\n";
96 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 8
97
98 $ok= WriteFile( $h1, "ly was other text\n", 0, $len, [] )
99   &&  $len == length("ly was other text\n");
100 $ok or print "# <$len> should be <",
101   length("ly was other text\n"),">: ",fileLastError(),"\n";
102 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 9
103
104 $ok= ReadFile( $h2, $text, 80, $len, [] )
105  &&  $len == length($text);
106 $ok or print "# <$len> should be <",length($text),
107   ">: ",fileLastError(),"\n";
108 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 10
109
110 $ok= $text eq "Originally was other text\n";
111 if( !$ok ) {
112     $text =~ s/\r/\\r/g;   $text =~ s/\n/\\n/g;
113     print "# <$text> should be <Originally was other text\\n>.\n";
114 }
115 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 11
116
117 $ok= CloseHandle($h2);
118 $ok or print "# ",fileLastError(),"\n";
119 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 12
120
121 $ok= ! ReadFile( $h2, $text, 80, $len, [] )
122  &&  Win32API::File::_fileLastError() == 6; # handle is invalid
123 $ok or print "# ",fileLastError(),"\n";
124 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 13
125
126 CloseHandle($h1);
127
128 $ok= $h1= createFile( "CanWrite.txt", "rw", FILE_SHARE_WRITE,
129               { Create=>CREATE_ALWAYS } );
130 $ok or print "# ",fileLastError(),"\n";
131 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 14
132
133 $ok= WriteFile( $h1, "Just this and not this", 10, [], [] );
134 $ok or print "# ",fileLastError(),"\n";
135 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 15
136
137 $ok= $h2= createFile( "CanWrite.txt", "wk", { Share=>"rw" } );
138 $ok or print "# ",fileLastError(),"\n";
139 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 16
140
141 $ok= OsFHandleOpen( "APP", $h2, "wat" );
142 $ok or print "# ",fileLastError(),"\n";
143 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 17
144
145 $ok=  $h2 == GetOsFHandle( "APP" );
146 $ok or print "# $h2 != ",GetOsFHandle("APP"),"\n";
147 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 18
148
149 {   my $save= select(APP);   $|= 1;  select($save);   }
150 $ok= print APP "is enough\n";
151 $ok or print "# ",fileLastError(),"\n";
152 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 19
153
154 SetFilePointer($h1, 0, [], FILE_BEGIN) if $^O eq 'cygwin';
155
156 $ok= ReadFile( $h1, $text, 0, [], [] );
157 $ok or print "# ",fileLastError(),"\n";
158 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 20
159
160 $ok=  $text eq "is enough\r\n";
161 if( !$ok ) {
162     $text =~ s/\r/\\r/g;
163     $text =~ s/\n/\\n/g;
164     print "# <$text> should be <is enough\\r\\n>\n";
165 }
166 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 21
167
168 $skip = "";
169 if ($^O eq 'cygwin') {
170     $ok = 1;
171     $skip = " # skip cygwin can delete open files";
172 }
173 else {
174     unlink("CanWrite.txt");
175     $ok = -e "CanWrite.txt" &&  $! =~ /permission denied/i;
176     $ok or print "# $!\n";
177 }
178 print $ok ? "" : "not ", "ok ", ++$test, "$skip\n"; # ok 22
179
180 close(APP);             # Also does C<CloseHandle($h2)>
181 ## CloseHandle( $h2 );
182 CloseHandle( $h1 );
183
184 $ok= ! DeleteFile( "ReadOnly.txt" )
185  &&  Win32API::File::_fileLastError() == 5; # access is denied
186 $ok or print "# ",fileLastError(),"\n";
187 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 23
188
189 $ok= ! CopyFile( "ReadOnly.txt", "CanWrite.txt", 1 )
190  &&  Win32API::File::_fileLastError() == 80; # file exists
191 $ok or print "# ",fileLastError(),"\n";
192 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 24
193
194 $ok= ! CopyFile( "CanWrite.txt", "ReadOnly.txt", 0 )
195  &&  Win32API::File::_fileLastError() == 5; # access is denied
196 $ok or print "# ",fileLastError(),"\n";
197 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 25
198
199 $ok= ! MoveFile( "NoSuchFile", "NoSuchDest" )
200  &&  Win32API::File::_fileLastError() == 2; # not find the file
201 $ok or print "# ",fileLastError(),"\n";
202 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 26
203
204 $ok= ! MoveFileEx( "NoSuchFile", "NoSuchDest", 0 )
205  &&  Win32API::File::_fileLastError() == 2; # not find the file
206 $ok or print "# ",fileLastError(),"\n";
207 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 27
208
209 $ok= ! MoveFile( "ReadOnly.txt", "CanWrite.txt" )
210  &&  Win32API::File::_fileLastError() == 183; # file already exists
211 $ok or print "# ",fileLastError(),"\n";
212 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 28
213
214 $ok= ! MoveFileEx( "ReadOnly.txt", "CanWrite.txt", 0 )
215  &&  Win32API::File::_fileLastError() == 183; # file already exists
216 $ok or print "# ",fileLastError(),"\n";
217 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 29
218
219 $ok= CopyFile( "ReadOnly.txt", "ReadOnly.cp", 1 )
220  &&  CopyFile( "CanWrite.txt", "CanWrite.cp", 1 );
221 $ok or print "# ",fileLastError(),"\n";
222 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 30
223
224 $ok= ! MoveFileEx( "CanWrite.txt", "ReadOnly.cp", MOVEFILE_REPLACE_EXISTING )
225  &&  Win32API::File::_fileLastError() == 5; # access is denied
226 $ok or print "# ",fileLastError(),"\n";
227 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 31
228
229 $ok= MoveFileEx( "ReadOnly.cp", "CanWrite.cp", MOVEFILE_REPLACE_EXISTING );
230 $ok or print "# ",fileLastError(),"\n";
231 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 32
232
233 $ok= MoveFile( "CanWrite.cp", "Moved.cp" );
234 $ok or print "# ",fileLastError(),"\n";
235 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 33
236
237 $ok= ! unlink( "ReadOnly.cp" )
238  &&  $! =~ /no such file/i
239  &&  ! unlink( "CanWrite.cp" )
240  &&  $! =~ /no such file/i;
241 $ok or print "# $!\n";
242 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 34
243
244 $ok= ! DeleteFile( "Moved.cp" )
245  &&  Win32API::File::_fileLastError() == 5; # access is denied
246 $ok or print "# ",fileLastError(),"\n";
247 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 35
248
249 if ($^O eq 'cygwin') {
250     chmod( 0200 | 07777 & (stat("Moved.cp"))[2], "Moved.cp" );
251 }
252 else {
253     system( "attrib -r Moved.cp" );
254 }
255
256 $ok= DeleteFile( "Moved.cp" );
257 $ok or print "# ",fileLastError(),"\n";
258 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 36
259
260 $new= SEM_FAILCRITICALERRORS|SEM_NOOPENFILEERRORBOX;
261 $old= SetErrorMode( $new );
262 $renew= SetErrorMode( $old );
263 $reold= SetErrorMode( $old );
264
265 $ok= $old == $reold;
266 $ok or print "# $old != $reold: ",fileLastError(),"\n";
267 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 37
268
269 $ok= ($renew&$new) == $new;
270 $ok or print "# $new != $renew: ",fileLastError(),"\n";
271 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 38
272
273 $ok= @drives= getLogicalDrives();
274 $ok && print "# @drives\n";
275 $ok or print "# ",fileLastError(),"\n";
276 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 39
277
278 $ok=  $drives[0] !~ /^[ab]/  ||  DRIVE_REMOVABLE == GetDriveType($drives[0]);
279 $ok or print "# ",DRIVE_REMOVABLE," != ",GetDriveType($drives[0]),
280   ": ",fileLastError(),"\n";
281 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 40
282
283 $drive= substr( $ENV{WINDIR}, 0, 3 );
284
285 $ok= 1 == grep /^\Q$drive\E/i, @drives;
286 $ok or print "# No $drive found in list of drives.\n";
287 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 41
288
289 $ok= DRIVE_FIXED == GetDriveType( $drive );
290 $ok or print
291   "# ",DRIVE_FIXED," != ",GetDriveType($drive),": ",fileLastError(),"\n";
292 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 42
293
294 $ok=  GetVolumeInformation( $drive, $vol, 64, $ser, $max, $flag, $fs, 16 );
295 $ok or print "# ",fileLastError(),"\n";
296 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 43
297 $vol= $ser= $max= $flag= $fs= "";       # Prevent warnings.
298
299 chop($drive);
300 $ok= QueryDosDevice( $drive, $dev, 80 );
301 $ok or print "# $drive: ",fileLastError(),"\n";
302 if( $ok ) {
303     ( $text= $dev ) =~ s/\0/\\0/g;
304     print "# $drive => $text\n";
305 }
306 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 44
307
308 $bits= GetLogicalDrives();
309 $let= 25;
310 $bit= 1<<$let;
311 while(  $bit & $bits  ) {
312     $let--;
313     $bit >>= 1;
314 }
315 $let= pack( "C", $let + unpack("C","A") ) . ":";
316 print "# Querying undefined $let.\n";
317
318 $ok= DefineDosDevice( 0, $let, $ENV{WINDIR} );
319 $ok or print "# $let,$ENV{WINDIR}: ",fileLastError(),"\n";
320 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 45
321
322 $ok=  -s $let."/Win.ini"  ==  -s $ENV{WINDIR}."/Win.ini";
323 $ok or print "# ", -s $let."/Win.ini", " vs. ",
324   -s $ENV{WINDIR}."/Win.ini", ": ",fileLastError(),"\n";
325 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 46
326
327 $ok= DefineDosDevice( DDD_REMOVE_DEFINITION|DDD_EXACT_MATCH_ON_REMOVE,
328                       $let, $ENV{WINDIR} );
329 $ok or print "# $let,$ENV{WINDIR}: ",fileLastError(),"\n";
330 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 47
331
332 $ok= ! -f $let."/Win.ini"
333   &&  $! =~ /no such file/i;
334 $ok or print "# $!\n";
335 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 48
336
337 $ok= DefineDosDevice( DDD_RAW_TARGET_PATH, $let, $dev );
338 if( !$ok  ) {
339     ( $text= $dev ) =~ s/\0/\\0/g;
340     print "# $let,$text: ",fileLastError(),"\n";
341 }
342 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 49
343
344 $ok= -f $let.substr($ENV{WINDIR},3)."/win.ini";
345 $ok or print "# ",fileLastError(),"\n";
346 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 50
347
348 $ok= DefineDosDevice( DDD_REMOVE_DEFINITION|DDD_EXACT_MATCH_ON_REMOVE
349                      |DDD_RAW_TARGET_PATH, $let, $dev );
350 $ok or print "# $let,$dev: ",fileLastError(),"\n";
351 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 51
352
353 my $path = $ENV{WINDIR};
354 my $attrs = GetFileAttributes( $path );
355 $ok= $attrs != INVALID_FILE_ATTRIBUTES;
356 $ok or print "# $path gave invalid attribute value, attrs=$attrs: ",fileLastError(),"\n";
357 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 52
358
359 $ok= ($attrs & FILE_ATTRIBUTE_DIRECTORY);
360 $ok or print "# $path not a directory, attrs=$attrs: ",fileLastError(),"\n";
361 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 53
362
363 $path .= "/win.ini";
364 $attrs = GetFileAttributes( $path );
365 $ok= $attrs != INVALID_FILE_ATTRIBUTES;
366 $ok or print "# $path gave invalid attribute value, attrs=$attrs: ",fileLastError(),"\n";
367 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 54
368
369 $ok= !($attrs & FILE_ATTRIBUTE_DIRECTORY);
370 $ok or print "# $path is a directory, attrs=$attrs: ",fileLastError(),"\n";
371 print $ok ? "" : "not ", "ok ", ++$test, "\n";  # ok 55
372
373 #       DefineDosDevice
374 #       GetFileType
375 #       GetVolumeInformation
376 #       QueryDosDevice
377 #Add a drive letter that points to our temp directory
378 #Add a drive letter that points to the drive our directory is in
379
380 #winnt.t:
381 # get first drive letters and use to test disk and storage IOCTLs
382 # "//./PhysicalDrive0"
383 #       DeviceIoControl
384
385 my %consts;
386 my @consts= @Win32API::File::EXPORT_OK;
387 @consts{@consts}= @consts;
388
389 my( @noargs, %noargs )= qw(
390   attrLetsToBits fileLastError getLogicalDrives GetLogicalDrives );
391 @noargs{@noargs}= @noargs;
392
393 foreach $func ( @{$Win32API::File::EXPORT_TAGS{Func}} ) {
394     delete $consts{$func};
395     if(  defined( $noargs{$func} )  ) {
396         $ok=  ! eval("$func(0,0)")  &&  $@ =~ /(::|\s)_?${func}A?[(:\s]/;
397     } else {
398         $ok=  ! eval("$func()")  &&  $@ =~ /(::|\s)_?${func}A?[(:\s]/;
399     }
400     $ok or print "# $func: $@\n";
401     print $ok ? "" : "not ", "ok ", ++$test, "\n";
402 }
403
404 foreach $func ( @{$Win32API::File::EXPORT_TAGS{FuncA}},
405                 @{$Win32API::File::EXPORT_TAGS{FuncW}} ) {
406     $ok=  ! eval("$func()")  &&  $@ =~ /::_?${func}\(/;
407     delete $consts{$func};
408     $ok or print "# $func: $@\n";
409     print $ok ? "" : "not ", "ok ", ++$test, "\n";
410 }
411
412 foreach $const ( keys(%consts) ) {
413     $ok= eval("my \$x= $const(); 1");
414     $ok or print "# Constant $const: $@\n";
415     print $ok ? "" : "not ", "ok ", ++$test, "\n";
416 }
417
418 chdir( $temp );
419 if (-e "$dir/ReadOnly.txt") {
420     chmod 0777, "$dir/ReadOnly.txt";
421     unlink "$dir/ReadOnly.txt";
422 }
423 unlink "$dir/CanWrite.txt" if -e "$dir/CanWrite.txt";
424 rmdir $dir;
425
426 __END__