=head1 NAME

XBase::Base - Base input output module for XBase suite

=cut

package XBase::Base;

use strict;
use IO::File;
use Fcntl qw( O_RDWR O_RDONLY );

### I _Realy_ hate to have this code here!
BEGIN { local $^W = 0;
	if ($^O =~ /mswin/i) { eval 'use Fcntl qw( O_BINARY )' }
	else { eval ' sub O_BINARY { 0 } ' }
	}

$XBase::Base::VERSION = '0.129';

# Sets the debug level
$XBase::Base::DEBUG = 0;
sub DEBUG () { $XBase::Base::DEBUG };

my $SEEK_VIA_READ = 0;

# Holds the text of the global error, if there was one
$XBase::Base::errstr = '';
# Fetch the error message
sub errstr ()	{ ( ref $_[0] ? $_[0]->{'errstr'} : $XBase::Base::errstr ); }

# Set errstr and print error on STDERR if there is debug level
sub Error (@)
	{
	my $self = shift;
	( ref $self ? $self->{'errstr'} : $XBase::Base::errstr ) = join '', @_;
	}
# Null the errstr
sub NullError
	{ shift->Error(''); }


# Build the object in the memory, open the file
sub new
	{
	__PACKAGE__->NullError();
	my $class = shift;
	my $new = bless {}, $class;
	if (@_ and not $new->open(@_)) { return; }
	return $new;
	}
# Open the specified file. Use the read_header to load the header data
sub open
	{
	__PACKAGE__->NullError();
	my $self = shift;
	my %options;
	if (scalar(@_) % 2) { $options{'name'} = shift; }
		$self->{'openoptions'} = { %options, @_ };
	%options = (%options, @_);
	if (defined $self->{'fh'}) { $self->close(); }

	my $fh = new IO::File;
	my $rw;
	
	if ($options{'name'} eq '-')
		{
		$fh->fdopen(fileno(STDIN), 'r');
		$self->{'stream'} = 1;
		SEEK_VIA_READ(1);
		$rw = 0;
		}
	else
		{
		my $ok = 1;
		if (not $options{'readonly'}) {
			if ($fh->open($options{'name'}, O_RDWR|O_BINARY))
				{ $rw = 1; }
			else	{ $ok = 0; }
			}
		if (not $ok) {
			if ($fh->open($options{'name'}, O_RDONLY|O_BINARY))
				{ $rw = 0; $ok = 1; }
			else    { $ok = 0; }
			}
		if (not $ok) {
			__PACKAGE__->Error("Error opening file $options{'name'}: $!\n"); return; }
		}

	$self->{'tell'} = 0 if $SEEK_VIA_READ;
	$fh->autoflush();

	binmode($fh);
	@{$self}{ qw( fh filename rw ) } = ($fh, $options{'name'}, $rw);
	## $self->locksh();

		# read_header should be defined in the derived class
	$self->read_header(@_);
	}
# Close the file
sub close
	{
	my $self = shift;
	$self->NullError();
	if (not defined $self->{'fh'})
		{ $self->Error("Can't close file that is not opened\n"); return; }
	$self->{'fh'}->close();
	delete $self->{'fh'};
	1;
	}
# Read from the filehandle
sub read
	{
	my $self = shift;
	my $fh = $self->{'fh'} or return;
	my $result = $fh->read(@_);
	if (defined $result and defined $self->{'tell'})
		{ $self->{'tell'} += $result; }
	$result;
	}
# Tell the position
sub tell
	{
	my $self = shift;
	if (defined $self->{'tell'})
		{ return $self->{'tell'}; }
	return $self->{'fh'}->tell();
	}
# Drop (unlink) the file
sub drop
	{
	my $self = shift;
	$self->NullError();
	if (defined $self->{'filename'})
		{
		my $filename = $self->{'filename'};
		$self->close() if defined $self->{'fh'};
		if (not unlink $filename)
			{ $self->Error("Error unlinking file $filename: $!\n"); return; };
		}
	1;	
	}

# Create new file
sub create_file
	{
	my $self = shift;
	my ($filename, $perms) = @_;
	if (not defined $filename)
		{ __PACKAGE__->Error("Name has to be specified when creating new file\n"); return; }
	if (-f $filename)
		{ __PACKAGE__->Error("File $filename already exists\n"); return; }

	$perms = 0644 unless defined $perms;
	my $fh = new IO::File;
	$fh->open($filename, 'w+', $perms) or return;
	binmode($fh);
	@{$self}{ qw( fh filename rw ) } = ($fh, $filename, 1);
	return $self;
	}


# Compute the offset of the record
sub get_record_offset
	{
	my ($self, $num) = @_;
	my ($header_len, $record_len) = ($self->{'header_len'},
						$self->{'record_len'});
	unless (defined $header_len and defined $record_len)
		{ $self->Error("Header and record lengths not known in get_record_offset\n"); return; }
	unless (defined $num)
		{ $self->Error("Number of the record must be specified in get_record_offset\n"); return; }
	return $header_len + $num * $record_len;
	}


# Seek to start of the record
sub seek_to_record
	{
	my ($self, $num) = @_;
	defined (my $offset = $self->get_record_offset($num)) or return;
	$self->seek_to($offset);
	}
# Seek to absolute position
sub seek_to_seek
	{
	my ($self, $offset) = @_;
	unless (defined $self->{'fh'})
		{ $self->Error("Cannot seek on unopened file\n"); return; }
	unless ($self->{'fh'}->seek($offset, 0))
		{ $self->Error("Seek error (file $self->{'filename'}, offset $offset): $!\n"); return; };
	1;
	}
sub seek_to_read
	{
	my ($self, $offset) = @_;
	unless (defined $self->{'fh'})
		{ $self->Error("Cannot seek on unopened file\n"); return; }
	my $tell = $self->tell();
	if ($offset < $tell)
		{ $self->Error("Cannot seek backwards without using seek ($offset < $tell)\n"); return; };
	if ($offset > $tell)
		{
		my $undef;
		$self->read($undef, $offset - $tell);
		$tell = $self->tell();
		}
	if ($tell != $offset)
		{ $self->Error("Some error occured during read-seek: $!\n"); return; };
	1;
	}
sub SEEK_VIA_READ
	{
	local $^W = 0;
	if ($_[0])
		{ *seek_to = \&seek_to_read; $SEEK_VIA_READ = 1; }
	else
		{ *seek_to = \&seek_to_seek; $SEEK_VIA_READ = 0; }
	}
SEEK_VIA_READ(0);

# Read the record of given number. The second parameter is the length of
# the record to read. It can be undefined, meaning read the whole record,
# and it can be negative, meaning at most the length
sub read_record
	{
	my ($self, $num, $in_length) = @_;
	if (not defined $num)
		{ $self->Error("Number of the record must be defined when reading it\n"); return; }
	if ($self->last_record > 0 and $num > $self->last_record)
		{ $self->Error("Can't read record $num, there is not so many of them\n"); return; }
	if (not defined $in_length)
		{ $in_length = $self->{'record_len'}; }
	if ($in_length < 0)
		{ $in_length = -$self->{'record_len'}; }

	defined (my $offset = $self->get_record_offset($num)) or return;
	$self->read_from($offset, $in_length);
	}
sub read_from
	{
	my ($self, $offset, $in_length) = @_;
	unless (defined $offset)
		{ $self->Error("Offset to read from must be specified\n"); return; }
	$self->seek_to($offset) or return;
	my $length = $in_length;
	$length = -$length if $length < 0;
	my $buffer;
	my $read = $self->read($buffer, $length);
	if (not defined $read or ($in_length > 0 and $read != $in_length))
		{ $self->Error("Error reading $in_length bytes from $self->{'filename'}\n"); return; }
	$buffer;
	}


# Write the given record
sub write_record
	{
	my ($self, $num) = (shift, shift);
	defined (my $offset = $self->get_record_offset($num)) or return;
	defined $self->write_to($offset, @_) or return;
	$num == 0 ? '0E0' : $num;
	}
# Write data directly to offset
sub write_to
	{
	my ($self, $offset) = (shift, shift);
	if (not $self->{'rw'})
		{ $self->Error("The file $self->{'filename'} is not writable\n"); return; }
	$self->seek_to($offset) or return;
	local ($,, $\) = ('', '');
	$self->{'fh'}->print(@_) or
		do { $self->Error("Error writing to offset $offset in file $self->{'filename'}: $!\n"); return; } ;
	$offset == 0 ? '0E0' : $offset;
	}


sub locksh	{ _locksh(shift->{'fh'}) }
sub lockex	{ _lockex(shift->{'fh'}) }
sub unlock	{ _unlock(shift->{'fh'}) }

sub _locksh	{ flock(shift, 1); }
sub _lockex	{ flock(shift, 2); }
sub _unlock	{ flock(shift, 8); }


1;

__END__

=head1 SYNOPSIS

Used indirectly, via XBase or XBase::Memo.

=head1 DESCRIPTION

This module provides catch-all I/O methods for other XBase classes,
should be used by people creating additional XBase classes/methods.
There is nothing interesting in here for users of the XBase(3) module.
Methods in XBase::Base return nothing (undef) on error and the error
message can be retrieved using the B<errstr> method.

Methods are:

=over 4

=item new

Constructor. Creates the object and if the file name is specified,
opens the file.

=item open

Opens the file and using method read_header reads the header and sets
the object's data structure. The read_header should be defined in the
derived class, there is no default.

=item close

Closes the file, doesn't destroy the object.

=item drop

Unlinks the file.

=item create_file

Creates file of given name. Second (optional) paramater is the
permission specification for the file.

=back

The reading/writing methods assume that the file has got header of
length header_len bytes (possibly 0) and then records of length
record_len. These two values should be set by the read_header method.

=over 4

=item seek_to, seek_to_record

Seeks to absolute position or to the start of the record.

=item read_record, read_from

Reads data from specified position (offset) or from the given record.
The second parameter (optional for B<read_record>) is the length to
read. It can be negative, and at that case the read will not complain
if the file is shorter than requested.

=item write_to, write_record

Writes data to the absolute position or to specified record position.
The data is not padded to record_len, just written out.

=back

General locking methods are B<locksh>, B<lockex> and B<unlock>, they
call B<_locksh>, B<_lockex> and B<_unlock> which can be redefined to
allow any way for locking (not only the default flock). The user is
responsible for calling the lock if he needs it.

No more description -- check the source code if you need to know more.

=head1 VERSION

0.129

=head1 AUTHOR

(c) 1997--1999 Jan Pazdziora, adelton@fi.muni.cz

=head1 SEE ALSO

perl(1), XBase(3)