file.pm

source of perl for linux application,

	$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 {}