-
Notifications
You must be signed in to change notification settings - Fork 8
/
File.pm
executable file
·3046 lines (2190 loc) · 95.5 KB
/
File.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
# File.pm -- Low-level access to Win32 file/dir functions/constants.
package Win32API::File;
use strict;
use integer;
use Carp;
use Config qw( %Config );
use Fcntl qw( O_RDONLY O_RDWR O_WRONLY O_APPEND O_BINARY O_TEXT );
use vars qw( $VERSION @ISA );
use vars qw( @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS );
$VERSION= '0.1203';
use base qw( Exporter DynaLoader Tie::Handle IO::File );
# Math::BigInt optimizations courtesy of Tels
my $_64BITINT;
BEGIN {
$_64BITINT = defined($Config{use64bitint}) &&
($Config{use64bitint} eq 'define');
require Math::BigInt unless $_64BITINT;
}
my $THIRTY_TWO = $_64BITINT ? 32 : Math::BigInt->new(32);
my $FFFFFFFF = $_64BITINT ? 0xFFFFFFFF : Math::BigInt->new(0xFFFFFFFF);
@EXPORT= qw();
%EXPORT_TAGS= (
Func => [qw( attrLetsToBits createFile
fileConstant fileLastError getLogicalDrives
CloseHandle CopyFile CreateFile
DefineDosDevice DeleteFile DeviceIoControl
FdGetOsFHandle GetDriveType GetFileAttributes GetFileType
GetHandleInformation GetLogicalDrives GetLogicalDriveStrings
GetOsFHandle GetVolumeInformation IsRecognizedPartition
IsContainerPartition MoveFile MoveFileEx
OsFHandleOpen OsFHandleOpenFd QueryDosDevice
ReadFile SetErrorMode SetFilePointer
SetHandleInformation WriteFile GetFileSize
getFileSize setFilePointer GetOverlappedResult)],
FuncA => [qw(
CopyFileA CreateFileA DefineDosDeviceA
DeleteFileA GetDriveTypeA GetFileAttributesA GetLogicalDriveStringsA
GetVolumeInformationA MoveFileA MoveFileExA
QueryDosDeviceA )],
FuncW => [qw(
CopyFileW CreateFileW DefineDosDeviceW
DeleteFileW GetDriveTypeW GetFileAttributesW GetLogicalDriveStringsW
GetVolumeInformationW MoveFileW MoveFileExW
QueryDosDeviceW )],
Misc => [qw(
CREATE_ALWAYS CREATE_NEW FILE_BEGIN
FILE_CURRENT FILE_END INVALID_HANDLE_VALUE
OPEN_ALWAYS OPEN_EXISTING TRUNCATE_EXISTING )],
DDD_ => [qw(
DDD_EXACT_MATCH_ON_REMOVE DDD_RAW_TARGET_PATH
DDD_REMOVE_DEFINITION )],
DRIVE_ => [qw(
DRIVE_UNKNOWN DRIVE_NO_ROOT_DIR DRIVE_REMOVABLE
DRIVE_FIXED DRIVE_REMOTE DRIVE_CDROM
DRIVE_RAMDISK )],
FILE_ => [qw(
FILE_READ_DATA FILE_LIST_DIRECTORY
FILE_WRITE_DATA FILE_ADD_FILE
FILE_APPEND_DATA FILE_ADD_SUBDIRECTORY
FILE_CREATE_PIPE_INSTANCE FILE_READ_EA
FILE_WRITE_EA FILE_EXECUTE
FILE_TRAVERSE FILE_DELETE_CHILD
FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES
FILE_ALL_ACCESS FILE_GENERIC_READ
FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE )],
FILE_ATTRIBUTE_ => [qw(
INVALID_FILE_ATTRIBUTES
FILE_ATTRIBUTE_DEVICE FILE_ATTRIBUTE_DIRECTORY
FILE_ATTRIBUTE_ENCRYPTED FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
FILE_ATTRIBUTE_REPARSE_POINT FILE_ATTRIBUTE_SPARSE_FILE
FILE_ATTRIBUTE_ARCHIVE FILE_ATTRIBUTE_COMPRESSED
FILE_ATTRIBUTE_HIDDEN FILE_ATTRIBUTE_NORMAL
FILE_ATTRIBUTE_OFFLINE FILE_ATTRIBUTE_READONLY
FILE_ATTRIBUTE_SYSTEM FILE_ATTRIBUTE_TEMPORARY )],
FILE_FLAG_ => [qw(
FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_DELETE_ON_CLOSE
FILE_FLAG_NO_BUFFERING FILE_FLAG_OVERLAPPED
FILE_FLAG_POSIX_SEMANTICS FILE_FLAG_RANDOM_ACCESS
FILE_FLAG_SEQUENTIAL_SCAN FILE_FLAG_WRITE_THROUGH
FILE_FLAG_OPEN_REPARSE_POINT )],
FILE_SHARE_ => [qw(
FILE_SHARE_DELETE FILE_SHARE_READ FILE_SHARE_WRITE )],
FILE_TYPE_ => [qw(
FILE_TYPE_CHAR FILE_TYPE_DISK FILE_TYPE_PIPE
FILE_TYPE_UNKNOWN )],
FS_ => [qw(
FS_CASE_IS_PRESERVED FS_CASE_SENSITIVE
FS_UNICODE_STORED_ON_DISK FS_PERSISTENT_ACLS
FS_FILE_COMPRESSION FS_VOL_IS_COMPRESSED )],
FSCTL_ => [qw(
FSCTL_SET_REPARSE_POINT FSCTL_GET_REPARSE_POINT
FSCTL_DELETE_REPARSE_POINT )],
HANDLE_FLAG_ => [qw(
HANDLE_FLAG_INHERIT HANDLE_FLAG_PROTECT_FROM_CLOSE )],
IOCTL_STORAGE_ => [qw(
IOCTL_STORAGE_CHECK_VERIFY IOCTL_STORAGE_MEDIA_REMOVAL
IOCTL_STORAGE_EJECT_MEDIA IOCTL_STORAGE_LOAD_MEDIA
IOCTL_STORAGE_RESERVE IOCTL_STORAGE_RELEASE
IOCTL_STORAGE_FIND_NEW_DEVICES IOCTL_STORAGE_GET_MEDIA_TYPES
)],
IOCTL_DISK_ => [qw(
IOCTL_DISK_FORMAT_TRACKS IOCTL_DISK_FORMAT_TRACKS_EX
IOCTL_DISK_GET_DRIVE_GEOMETRY IOCTL_DISK_GET_DRIVE_LAYOUT
IOCTL_DISK_GET_MEDIA_TYPES IOCTL_DISK_GET_PARTITION_INFO
IOCTL_DISK_HISTOGRAM_DATA IOCTL_DISK_HISTOGRAM_RESET
IOCTL_DISK_HISTOGRAM_STRUCTURE IOCTL_DISK_IS_WRITABLE
IOCTL_DISK_LOGGING IOCTL_DISK_PERFORMANCE
IOCTL_DISK_REASSIGN_BLOCKS IOCTL_DISK_REQUEST_DATA
IOCTL_DISK_REQUEST_STRUCTURE IOCTL_DISK_SET_DRIVE_LAYOUT
IOCTL_DISK_SET_PARTITION_INFO IOCTL_DISK_VERIFY )],
GENERIC_ => [qw(
GENERIC_ALL GENERIC_EXECUTE
GENERIC_READ GENERIC_WRITE )],
MEDIA_TYPE => [qw(
Unknown F5_1Pt2_512 F3_1Pt44_512
F3_2Pt88_512 F3_20Pt8_512 F3_720_512
F5_360_512 F5_320_512 F5_320_1024
F5_180_512 F5_160_512 RemovableMedia
FixedMedia F3_120M_512 )],
MOVEFILE_ => [qw(
MOVEFILE_COPY_ALLOWED MOVEFILE_DELAY_UNTIL_REBOOT
MOVEFILE_REPLACE_EXISTING MOVEFILE_WRITE_THROUGH )],
SECURITY_ => [qw(
SECURITY_ANONYMOUS SECURITY_CONTEXT_TRACKING
SECURITY_DELEGATION SECURITY_EFFECTIVE_ONLY
SECURITY_IDENTIFICATION SECURITY_IMPERSONATION
SECURITY_SQOS_PRESENT )],
SEM_ => [qw(
SEM_FAILCRITICALERRORS SEM_NOGPFAULTERRORBOX
SEM_NOALIGNMENTFAULTEXCEPT SEM_NOOPENFILEERRORBOX )],
PARTITION_ => [qw(
PARTITION_ENTRY_UNUSED PARTITION_FAT_12
PARTITION_XENIX_1 PARTITION_XENIX_2
PARTITION_FAT_16 PARTITION_EXTENDED
PARTITION_HUGE PARTITION_IFS
PARTITION_FAT32 PARTITION_FAT32_XINT13
PARTITION_XINT13 PARTITION_XINT13_EXTENDED
PARTITION_PREP PARTITION_UNIX
VALID_NTFT PARTITION_NTFT )],
STD_HANDLE_ => [qw(
STD_INPUT_HANDLE STD_OUTPUT_HANDLE
STD_ERROR_HANDLE )],
);
@EXPORT_OK= ();
{
my $key;
foreach $key ( keys(%EXPORT_TAGS) ) {
push( @EXPORT_OK, @{$EXPORT_TAGS{$key}} );
#push( @EXPORT_FAIL, @{$EXPORT_TAGS{$key}} ) unless $key =~ /^Func/;
}
}
$EXPORT_TAGS{ALL}= \@EXPORT_OK;
bootstrap Win32API::File $VERSION;
# Preloaded methods go here.
# To convert C constants to Perl code in cFile.pc
# [instead of C or C++ code in cFile.h]:
# * Modify F<Makefile.PL> to add WriteMakeFile() =>
# CONST2PERL/postamble => [[ "Win32API::File" => ]] WRITE_PERL => 1.
# * Either comment out C<#include "cFile.h"> from F<File.xs>
# or make F<cFile.h> an empty file.
# * Make sure the following C<if> block is not commented out.
# * "nmake clean", "perl Makefile.PL", "nmake"
if( ! defined &GENERIC_READ ) {
require "Win32API/File/cFile.pc";
}
sub fileConstant
{
my( $name )= @_;
if( 1 != @_ || ! $name || $name =~ /\W/ ) {
require Carp;
Carp::croak( 'Usage: ',__PACKAGE__,'::fileConstant("CONST_NAME")' );
}
my $proto= prototype $name;
if( defined \&$name
&& defined $proto
&& "" eq $proto ) {
no strict 'refs';
return &$name;
}
return undef;
}
# We provide this for backwards compatibility:
sub constant
{
my( $name )= @_;
my $value= fileConstant( $name );
if( defined $value ) {
$!= 0;
return $value;
}
$!= 11; # EINVAL
return 0;
}
# BEGIN {
# my $code= 'return _fileLastError(@_)';
# local( $!, $^E )= ( 1, 1 );
# if( $! ne $^E ) {
# $code= '
# local( $^E )= _fileLastError(@_);
# my $ret= $^E;
# return $ret;
# ';
# }
# eval "sub fileLastError { $code }";
# die "$@" if $@;
# }
package Win32API::File::_error;
use overload
'""' => sub {
require Win32 unless defined &Win32::FormatMessage;
$_ = Win32::FormatMessage(Win32API::File::_fileLastError());
tr/\r\n//d;
return $_;
},
'0+' => sub { Win32API::File::_fileLastError() },
'fallback' => 1;
sub new { return bless {}, shift }
sub set { Win32API::File::_fileLastError($_[1]); return $_[0] }
package Win32API::File;
my $_error = Win32API::File::_error->new();
sub fileLastError {
croak 'Usage: ',__PACKAGE__,'::fileLastError( [$setWin32ErrCode] )' if @_ > 1;
$_error->set($_[0]) if defined $_[0];
return $_error;
}
# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we
# need this next chunk to prevent Win32API::File->nonesuch() from
# looking for "nonesuch.al" and producing confusing error messages:
use vars qw($AUTOLOAD);
sub AUTOLOAD {
require Carp;
Carp::croak(
"Can't locate method $AUTOLOAD via package Win32API::File" );
}
# Replace "&rout;" with "goto &rout;" when that is supported on Win32.
# Aliases for non-Unicode functions:
sub CopyFile { &CopyFileA; }
sub CreateFile { &CreateFileA; }
sub DefineDosDevice { &DefineDosDeviceA; }
sub DeleteFile { &DeleteFileA; }
sub GetDriveType { &GetDriveTypeA; }
sub GetFileAttributes { &GetFileAttributesA; }
sub GetLogicalDriveStrings { &GetLogicalDriveStringsA; }
sub GetVolumeInformation { &GetVolumeInformationA; }
sub MoveFile { &MoveFileA; }
sub MoveFileEx { &MoveFileExA; }
sub QueryDosDevice { &QueryDosDeviceA; }
sub OsFHandleOpen {
if( 3 != @_ ) {
croak 'Win32API::File Usage: ',
'OsFHandleOpen(FILE,$hNativeHandle,"rwatb")';
}
my( $fh, $osfh, $access )= @_;
if( ! ref($fh) ) {
if( $fh !~ /('|::)/ ) {
$fh= caller() . "::" . $fh;
}
no strict "refs";
$fh= \*{$fh};
}
my( $mode, $pref );
if( $access =~ /r/i ) {
if( $access =~ /w/i ) {
$mode= O_RDWR;
$pref= "+<";
} else {
$mode= O_RDONLY;
$pref= "<";
}
} else {
if( $access =~ /w/i ) {
$mode= O_WRONLY;
$pref= ">";
} else {
# croak qq<Win32API::File::OsFHandleOpen(): >,
# qq<Access ($access) missing both "r" and "w">;
$mode= O_RDONLY;
$pref= "<";
}
}
$mode |= O_APPEND if $access =~ /a/i;
#$mode |= O_TEXT if $access =~ /t/i;
# Some versions of the Fcntl module are broken and won't autoload O_TEXT:
if( $access =~ /t/i ) {
my $o_text= eval "O_TEXT";
$o_text= 0x4000 if $@;
$mode |= $o_text;
}
$mode |= O_BINARY if $access =~ /b/i;
my $fd = eval { OsFHandleOpenFd( $osfh, $mode ) };
if ($@) {
return tie *{$fh}, __PACKAGE__, $osfh;
}
return undef unless $fd;
return open( $fh, $pref."&=".(0+$fd) );
}
sub GetOsFHandle {
if( 1 != @_ ) {
croak 'Win32API::File Usage: $OsFHandle= GetOsFHandle(FILE)';
}
my( $file )= @_;
if( ! ref($file) ) {
if( $file !~ /('|::)/ ) {
$file= caller() . "::" . $file;
}
no strict "refs";
# The eval "" is necessary in Perl 5.6, avoid it otherwise.
my $tied = !defined($^]) || $^] < 5.008
? eval "tied *{$file}"
: tied *{$file};
if (UNIVERSAL::isa($tied => __PACKAGE__)) {
return $tied->win32_handle;
}
$file= *{$file};
}
my( $fd )= fileno($file);
if( ! defined( $fd ) ) {
if( $file =~ /^\d+\Z/ ) {
$fd= $file;
} else {
return (); # $! should be set by fileno().
}
}
my $h= FdGetOsFHandle( $fd );
if( INVALID_HANDLE_VALUE() == $h ) {
$h= "";
} elsif( "0" eq $h ) {
$h= "0 but true";
}
return $h;
}
sub getFileSize {
croak 'Win32API::File Usage: $size= getFileSize($hNativeHandle)'
if @_ != 1;
my $handle = shift;
my $high_size = 0;
my $low_size = GetFileSize($handle, $high_size);
my $retval = $_64BITINT ? $high_size : Math::BigInt->new($high_size);
$retval <<= $THIRTY_TWO;
$retval += $low_size;
return $retval;
}
sub setFilePointer {
croak 'Win32API::File Usage: $pos= setFilePointer($hNativeHandle, $posl, $from_where)'
if @_ != 3;
my ($handle, $pos, $from_where) = @_;
my ($pos_low, $pos_high) = ($pos, 0);
if ($_64BITINT) {
$pos_low = ($pos & $FFFFFFFF);
$pos_high = (($pos >> $THIRTY_TWO) & $FFFFFFFF);
}
elsif (UNIVERSAL::isa($pos => 'Math::BigInt')) {
$pos_low = ($pos & $FFFFFFFF)->numify();
$pos_high = (($pos >> $THIRTY_TWO) & $FFFFFFFF)->numify();
}
my $retval = SetFilePointer($handle, $pos_low, $pos_high, $from_where);
if (defined $pos_high && $pos_high != 0) {
if (! $_64BITINT) {
$retval = Math::BigInt->new($retval);
$pos_high = Math::BigInt->new($pos_high);
}
$retval += $pos_high << $THIRTY_TWO;
}
return $retval;
}
sub attrLetsToBits
{
my( $lets )= @_;
my( %a )= (
"a"=>FILE_ATTRIBUTE_ARCHIVE(), "c"=>FILE_ATTRIBUTE_COMPRESSED(),
"h"=>FILE_ATTRIBUTE_HIDDEN(), "o"=>FILE_ATTRIBUTE_OFFLINE(),
"r"=>FILE_ATTRIBUTE_READONLY(), "s"=>FILE_ATTRIBUTE_SYSTEM(),
"t"=>FILE_ATTRIBUTE_TEMPORARY() );
my( $bits )= 0;
foreach( split(//,$lets) ) {
croak "Win32API::File::attrLetsToBits: Unknown attribute letter ($_)"
unless exists $a{$_};
$bits |= $a{$_};
}
return $bits;
}
use vars qw( @_createFile_Opts %_createFile_Opts );
@_createFile_Opts= qw( Access Create Share Attributes
Flags Security Model );
@_createFile_Opts{@_createFile_Opts}= (1) x @_createFile_Opts;
sub createFile
{
my $opts= "";
if( 2 <= @_ && "HASH" eq ref($_[$#_]) ) {
$opts= pop( @_ );
}
my( $sPath, $svAccess, $svShare )= @_;
if( @_ < 1 || 3 < @_ ) {
croak "Win32API::File::createFile() usage: \$hObject= createFile(\n",
" \$sPath, [\$svAccess_qrw_ktn_ce,[\$svShare_rwd,]]",
" [{Option=>\$Value}] )\n",
" options: @_createFile_Opts\nCalled";
}
my( $create, $flags, $sec, $model )= ( "", 0, [], 0 );
if( ref($opts) ) {
my @err= grep( ! $_createFile_Opts{$_}, keys(%$opts) );
@err and croak "_createFile: Invalid options (@err)";
$flags= $opts->{Flags} if exists( $opts->{Flags} );
$flags |= attrLetsToBits( $opts->{Attributes} )
if exists( $opts->{Attributes} );
$sec= $opts->{Security} if exists( $opts->{Security} );
$model= $opts->{Model} if exists( $opts->{Model} );
$svAccess= $opts->{Access} if exists( $opts->{Access} );
$create= $opts->{Create} if exists( $opts->{Create} );
$svShare= $opts->{Share} if exists( $opts->{Share} );
}
$svAccess= "r" unless defined($svAccess);
$svShare= "rw" unless defined($svShare);
if( $svAccess =~ /^[qrw ktn ce]*$/i ) {
( my $c= $svAccess ) =~ tr/qrw QRW//d;
$create= $c if "" ne $c && "" eq $create;
local( $_ )= $svAccess;
$svAccess= 0;
$svAccess |= GENERIC_READ() if /r/i;
$svAccess |= GENERIC_WRITE() if /w/i;
} elsif( "?" eq $svAccess ) {
croak
"Win32API::File::createFile: \$svAccess can use the following:\n",
" One or more of the following:\n",
"\tq -- Query access (same as 0)\n",
"\tr -- Read access (GENERIC_READ)\n",
"\tw -- Write access (GENERIC_WRITE)\n",
" At most one of the following:\n",
"\tk -- Keep if exists\n",
"\tt -- Truncate if exists\n",
"\tn -- New file only (fail if file already exists)\n",
" At most one of the following:\n",
"\tc -- Create if doesn't exist\n",
"\te -- Existing file only (fail if doesn't exist)\n",
" '' is the same as 'q k e'\n",
" 'r' is the same as 'r k e'\n",
" 'w' is the same as 'w t c'\n",
" 'rw' is the same as 'rw k c'\n",
" 'rt' or 'rn' implies 'c'.\n",
" Or \$svAccess can be numeric.\n", "Called from";
} elsif( $svAccess == 0 && $svAccess !~ /^[-+.]*0/ ) {
croak "Win32API::File::createFile: Invalid \$svAccess ($svAccess)";
}
if( $create =~ /^[ktn ce]*$/ ) {
local( $_ )= $create;
my( $k, $t, $n, $c, $e )= ( scalar(/k/i), scalar(/t/i),
scalar(/n/i), scalar(/c/i), scalar(/e/i) );
if( 1 < $k + $t + $n ) {
croak "Win32API::File::createFile: \$create must not use ",
qq<more than one of "k", "t", and "n" ($create)>;
}
if( $c && $e ) {
croak "Win32API::File::createFile: \$create must not use ",
qq<both "c" and "e" ($create)>;
}
my $r= ( $svAccess & GENERIC_READ() ) == GENERIC_READ();
my $w= ( $svAccess & GENERIC_WRITE() ) == GENERIC_WRITE();
if( ! $k && ! $t && ! $n ) {
if( $w && ! $r ) { $t= 1;
} else { $k= 1; }
}
if( $k ) {
if( $c || $w && ! $e ) { $create= OPEN_ALWAYS();
} else { $create= OPEN_EXISTING(); }
} elsif( $t ) {
if( $e ) { $create= TRUNCATE_EXISTING();
} else { $create= CREATE_ALWAYS(); }
} else { # $n
if( ! $e ) { $create= CREATE_NEW();
} else {
croak "Win32API::File::createFile: \$create must not use ",
qq<both "n" and "e" ($create)>;
}
}
} elsif( "?" eq $create ) {
croak 'Win32API::File::createFile: $create !~ /^[ktn ce]*$/;',
' pass $svAccess as "?" for more information.';
} elsif( $create == 0 && $create ne "0" ) {
croak "Win32API::File::createFile: Invalid \$create ($create)";
}
if( $svShare =~ /^[drw]*$/ ) {
my %s= ( "d"=>FILE_SHARE_DELETE(), "r"=>FILE_SHARE_READ(),
"w"=>FILE_SHARE_WRITE() );
my @s= split(//,$svShare);
$svShare= 0;
foreach( @s ) {
$svShare |= $s{$_};
}
} elsif( $svShare == 0 && $svShare !~ /^[-+.]*0/ ) {
croak "Win32API::File::createFile: Invalid \$svShare ($svShare)";
}
return CreateFileA(
$sPath, $svAccess, $svShare, $sec, $create, $flags, $model );
}
sub getLogicalDrives
{
my( $ref )= @_;
my $s= "";
if( ! GetLogicalDriveStringsA( 256, $s ) ) {
return undef;
}
if( ! defined($ref) ) {
return split( /\0/, $s );
} elsif( "ARRAY" ne ref($ref) ) {
croak 'Usage: C<@arr= getLogicalDrives()> ',
'or C<getLogicalDrives(\\@arr)>', "\n";
}
@$ref= split( /\0/, $s );
return $ref;
}
###############################################################################
# Experimental Tied Handle and Object Oriented interface. #
###############################################################################
sub new {
my $class = shift;
$class = ref $class || $class;
my $self = IO::File::new($class);
tie *$self, __PACKAGE__;
$self->open(@_) if @_;
return $self;
}
sub TIEHANDLE {
my ($class, $win32_handle) = @_;
$class = ref $class || $class;
return bless {
_win32_handle => $win32_handle,
_binmode => 0,
_buffered => 0,
_buffer => '',
_eof => 0,
_fileno => undef,
_access => 'r',
_append => 0,
}, $class;
}
# This is called for getting the tied object from hard refs to glob refs in
# some cases, for reasons I don't quite grok.
sub FETCH { return $_[0] }
# Public accessors
sub win32_handle{ $_[0]->{_win32_handle}||= $_[1] }
# Protected accessors
sub _buffer { $_[0]->{_buffer} ||= $_[1] }
sub _binmode { $_[0]->{_binmode} ||= $_[1] }
sub _fileno { $_[0]->{_fileno} ||= $_[1] }
sub _access { $_[0]->{_access} ||= $_[1] }
sub _append { $_[0]->{_append} ||= $_[1] }
# Tie interface
sub OPEN {
my $self = shift;
my $expr = shift;
croak "Only the two argument form of open is supported at this time" if @_;
# FIXME: this needs to parse the full Perl open syntax in $expr
my ($mixed, $mode, $path) =
($expr =~ /^\s* (\+)? \s* (<|>|>>)? \s* (.*?) \s*$/x);
croak "Unsupported open mode" if not $path;
my $access = 'r';
my $append = $mode eq '>>' ? 1 : 0;
if ($mixed) {
$access = 'rw';
} elsif($mode eq '>') {
$access = 'w';
}
my $w32_handle = createFile($path, $access);
$self->win32_handle($w32_handle);
$self->seek(1,2) if $append;
$self->_access($access);
$self->_append($append);
return 1;
}
sub BINMODE {
$_[0]->_binmode(1);
}
sub WRITE {
my ($self, $buf, $len, $offset, $overlap) = @_;
if ($offset) {
$buf = substr($buf, $offset);
$len = length($buf);
}
$len = length($buf) if not defined $len;
$overlap = [] if not defined $overlap;;
my $bytes_written = 0;
WriteFile (
$self->win32_handle, $buf, $len,
$bytes_written, $overlap
);
return $bytes_written;
}
sub PRINT {
my $self = shift;
my $buf = join defined $, ? $, : "" => @_;
$buf =~ s/\012/\015\012/sg unless $self->_binmode();
$buf .= $\ if defined $\;
$self->WRITE($buf, length($buf), 0);
}
sub READ {
my $self = shift;
my $into = \$_[0]; shift;
my ($len, $offset, $overlap) = @_;
my $buffer = defined $self->_buffer ? $self->_buffer : "";
my $buf_length = length($buffer);
my $bytes_read = 0;
my $data;
$offset = 0 if not defined $offset;
if ($buf_length >= $len) {
$data = substr($buffer, 0, $len => "");
$bytes_read = $len;
$self->_buffer($buffer);
} else {
if ($buf_length > 0) {
$len -= $buf_length;
substr($$into, $offset) = $buffer;
$offset += $buf_length;
}
$overlap ||= [];
ReadFile (
$self->win32_handle, $data, $len,
$bytes_read, $overlap
);
}
$$into = "" if not defined $$into;
substr($$into, $offset) = $data;
return $bytes_read;
}
sub READLINE {
my $self = shift;
my $line = "";
while ((index $line, $/) == -1) { # read until end of line marker
my $char = $self->GETC();
last if !defined $char || $char eq '';
$line .= $char;
}
return undef if $line eq '';
return $line;
}
sub FILENO {
my $self = shift;
return $self->_fileno() if defined $self->_fileno();
return -1 if $^O eq 'cygwin';
# FIXME: We don't always open the handle, better to query the handle or to set
# the right access info at TIEHANDLE time.
my $access = $self->_access();
my $mode = $access eq 'rw' ? O_RDWR :
$access eq 'w' ? O_WRONLY : O_RDONLY;
$mode |= O_APPEND if $self->_append();
$mode |= O_TEXT if not $self->_binmode();
return $self->_fileno ( OsfHandleOpenFd (
$self->win32_handle, $mode
));
}
sub SEEK {
my ($self, $pos, $whence) = @_;
$whence = 0 if not defined $whence;
my @file_consts = map {
fileConstant($_)
} qw(FILE_BEGIN FILE_CURRENT FILE_END);
my $from_where = $file_consts[$whence];
return setFilePointer($self->win32_handle, $pos, $from_where);
}
sub TELL {
# SetFilePointer with position 0 at FILE_CURRENT will return position.
return $_[0]->SEEK(0, 1);
}
sub EOF {
my $self = shift;
my $current = $self->TELL() + 0;
my $end = getFileSize($self->win32_handle) + 0;
return $current == $end;
}
sub CLOSE {
my $self = shift;
my $retval = 1;
if (defined $self->win32_handle) {
$retval = CloseHandle($self->win32_handle);
$self->win32_handle(undef);
}
return $retval;
}
# Only close the handle on explicit close, too many problems otherwise.
sub UNTIE {}
sub DESTROY {}
# End of Tie/OO Interface
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
__END__
=head1 NAME
Win32API::File - Low-level access to Win32 system API calls for files/dirs.
=head1 SYNOPSIS
use Win32API::File 0.08 qw( :ALL );
MoveFile( $Source, $Destination )
or die "Can't move $Source to $Destination: ",fileLastError(),"\n";
MoveFileEx( $Source, $Destination, MOVEFILE_REPLACE_EXISTING() )
or die "Can't move $Source to $Destination: ",fileLastError(),"\n";
[...]
=head1 DESCRIPTION
This provides fairly low-level access to the Win32 System API
calls dealing with files and directories.
To pass in C<NULL> as the pointer to an optional buffer, pass in
an empty list reference, C<[]>.
Beyond raw access to the API calls and related constants, this module
handles smart buffer allocation and translation of return codes.
All functions, unless otherwise noted, return a true value for success
and a false value for failure and set C<$^E> on failure.
=head2 Object Oriented/Tied Handle Interface
WARNING: this is new code, use at your own risk.
This version of C<Win32API::File> can be used like an C<IO::File> object:
my $file = Win32API::File->new("+> foo");
binmode $file;
print $file "hello there\n";
seek $file, 0, 0;
my $line = <$file>;
$file->close;
It also supports tying via a win32 handle (for example, from C<createFile()>):
tie FILE, 'Win32API::File', $win32_handle;
print FILE "...";
It has not been extensively tested yet and buffered I/O is not yet implemented.
=head2 Exports
Nothing is exported by default. The following tags can be used to
have large sets of symbols exported: C<":Func">, C<":FuncA">,
C<":FuncW">, C<":Misc">, C<":DDD_">, C<":DRIVE_">, C<":FILE_">,
C<":FILE_ATTRIBUTE_">, C<":FILE_FLAG_">, C<":FILE_SHARE_">,
C<":FILE_TYPE_">, C<":FS_">, C<":FSCTL_">, C<":HANDLE_FLAG_">,
C<":IOCTL_STORAGE_">, C<":IOCTL_DISK_">, C<":GENERIC_">,
C<":MEDIA_TYPE">, C<":MOVEFILE_">, C<":SECURITY_">, C<":SEM_">,
and C<":PARTITION_">.
=over
=item C<":Func">
The basic function names: C<attrLetsToBits>, C<createFile>,
C<fileConstant>, C<fileLastError>, C<getLogicalDrives>,
C<setFilePointer>, C<getFileSize>,
C<CloseHandle>, C<CopyFile>, C<CreateFile>,
C<DefineDosDevice>, C<DeleteFile>, C<DeviceIoControl>,
C<FdGetOsFHandle>, C<GetDriveType>, C<GetFileAttributes>,
C<GetFileSize>, C<GetFileType>, C<GetHandleInformation>,
C<GetLogicalDrives>, C<GetLogicalDriveStrings>, C<GetOsFHandle>,
C<GetOverlappedResult>, C<GetVolumeInformation>, C<IsContainerPartition>,
C<IsRecognizedPartition>, C<MoveFile>, C<MoveFileEx>,
C<OsFHandleOpen>, C<OsFHandleOpenFd>, C<QueryDosDevice>,
C<ReadFile>, C<SetErrorMode>, C<SetFilePointer>,
C<SetHandleInformation>, and C<WriteFile>.
=over
=item attrLetsToBits
=item C<$uBits= attrLetsToBits( $sAttributeLetters )>
Converts a string of file attribute letters into an unsigned value with
the corresponding bits set. C<$sAttributeLetters> should contain zero
or more letters from C<"achorst">:
=over
=item C<"a">
C<FILE_ATTRIBUTE_ARCHIVE>
=item C<"c">
C<FILE_ATTRIBUTE_COMPRESSED>
=item C<"h">
C<FILE_ATTRIBUTE_HIDDEN>
=item C<"o">
C<FILE_ATTRIBUTE_OFFLINE>
=item C<"r">
C<FILE_ATTRIBUTE_READONLY>
=item C<"s">
C<FILE_ATTRIBUTE_SYSTEM>
=item C<"t">
C<FILE_ATTRIBUTE_TEMPORARY>
=back
=item createFile
=item C<$hObject= createFile( $sPath )>
=item C<$hObject= createFile( $sPath, $rvhvOptions )>
=item C<$hObject= createFile( $sPath, $svAccess )>
=item C<$hObject= createFile( $sPath, $svAccess, $rvhvOptions )>
=item C<$hObject= createFile( $sPath, $svAccess, $svShare )>
=item C<$hObject= createFile( $sPath, $svAccess, $svShare, $rvhvOptions )>
This is a Perl-friendly wrapper around C<CreateFile>.
On failure, C<$hObject> gets set to a false value and C<regLastError()>
and C<$^E> are set to the reason for the failure. Otherwise,
C<$hObject> gets set to a Win32 native file handle which is always
a true value [returns C<"0 but true"> in the impossible(?) case of
the handle having a value of C<0>].
C<$sPath> is the path to the file [or device, etc.] to be opened. See
C<CreateFile> for more information on possible special values for
C<$sPath>.
C<$svAccess> can be a number containing the bit mask representing
the specific type(s) of access to the file that you desire. See the
C<$uAccess> parameter to C<CreateFile> for more information on these
values.
More likely, C<$svAccess> is a string describing the generic type of
access you desire and possibly the file creation options to use. In
this case, C<$svAccess> should contain zero or more characters from
C<"qrw"> [access desired], zero or one character each from C<"ktn">
and C<"ce">, and optional white space. These letters stand for,
respectively, "Query access", "Read access", "Write access", "Keep if
exists", "Truncate if exists", "New file only", "Create if none", and
"Existing file only". Case is ignored.
You can pass in C<"?"> for C<$svAccess> to have an error message
displayed summarizing its possible values. This is very handy when
doing on-the-fly programming using the Perl debugger:
Win32API::File::createFile: $svAccess can use the following:
One or more of the following:
q -- Query access (same as 0)
r -- Read access (GENERIC_READ)
w -- Write access (GENERIC_WRITE)
At most one of the following:
k -- Keep if exists
t -- Truncate if exists
n -- New file only (fail if file already exists)
At most one of the following:
c -- Create if doesn't exist
e -- Existing file only (fail if doesn't exist)
'' is the same as 'q k e'
'r' is the same as 'r k e'
'w' is the same as 'w t c'
'rw' is the same as 'rw k c'
'rt' or 'rn' implies 'c'.
Or $access can be numeric.
C<$svAccess> is designed to be "do what I mean", so you can skip
the rest of its explanation unless you are interested in the complex
details. Note that, if you want write access to a device, you need
to specify C<"k"> [and perhaps C<"e">, as in C<"w ke"> or C<"rw ke">]
since Win32 suggests C<OPEN_EXISTING> be used when opening a device.
=over