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