file.pm

source of perl for linux application,

# 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.1001_01';

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 )],
);
@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 if  $fd < 0;
    return  open( $fh, $pref."&=".$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);
	}