File Coverage

blib/lib/XBase/Base.pm

Criterion	Covered	Total	%
statement	141	189	74.6
branch	73	104	70.1
condition	12	18	66.6
subroutine	21	29	72.4
pod	10	23	43.4
total	257	363	70.8

=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 O_BINARY );

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

# 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, @_ } unless defined $self->{'openoptions'};
	%options = (%options, @_);
	if (defined $self->{'fh'}) { $self->close(); }

	my $external_fh = 0;
	my $fh = new IO::File;
	my $rw;

	if ($options{'name'} eq '-') {
		if (defined $options{'fh'}) {
			$fh = $options{'fh'};
			$external_fh = 1;
		} else {
			$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) unless $external_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__