File Coverage

blib/lib/VisionDB/Read.pm

Criterion	Covered	Total	%
statement	228	236	96.6
branch	81	108	75.0
condition	4	8	50.0
subroutine	26	27	96.3
pod	10	10	100.0
total	349	389	89.7

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this file.  If not, see .

package VisionDB::Read;

use strict;
use warnings;
use Exporter;
use File::Basename;
use Fcntl qw(SEEK_SET SEEK_CUR);

our ($VERSION, @ISA);
@ISA = qw( Exporter );
$VERSION = 0.04;

BEGIN {
}

END {
}
#--------------------------------------#
# Open DB segment from basename and    #
# segment number                       #
#   in: $basename, $seg                #
#   out: $handle                       #
#        die if error                  #
#--------------------------------------#

sub _open_db_segment {

	my ($basename, $segment) = @_;

	my $fh;
	my $fn = $basename.(($segment) ? ".d".sprintf("%02d", $segment) : '');

	open($fh, "<$fn") || die "open error ($!)\n";
	binmode $fh || die "cannot set binmode ($!)\n";
	return $fh;
}

#-------------------------------------#
# Destroy internal vars               #
#   in: -                             #
#   out: -                            #
#-------------------------------------#
sub _free_vars {

	my $self = shift;

	undef $self->{_err};
	undef $self->{_db_fname};
	undef $self->{_db_fpath};
	undef $self->{_fh};
	undef $self->{_rec_tot};
	undef $self->{_rec_cur};
	undef $self->{_version};
	undef $self->{_data_hlen};
	undef $self->{_data_cur};
	undef $self->{_seg_tot};
	undef $self->{_seg_cur};
	undef $self->{_seg_size};
	undef $self->{_data_start};
	undef $self->{_data_end};
	undef $self->{_data_keys};
}

#--------------------------------------#
# Read next valid record and increment #
# ptr to the next one                  #
#   in: $objref                        #
#   out: $data_arrayref                #
#	     die if error                  #
#--------------------------------------#
sub _read_next {

    my $self = shift;

	$self->{_rec_cur} >= 0 || die "invalid negatve record number\n";

	my $fh = $self->{_fh};
	my $dseg = $self->{_seg_cur};
	my $dptr = $self->{_data_cur};
    my $data;

	my $del = 0;
	do {
		my $buf;
		my ($h1, $h2) = (0, 0);
		$self->{_seg_size}*$dseg + $dptr < $self->{_data_end} || die "record ptr beyond EOF\n";
		(my $r = read($fh, $buf, $self->{_data_hlen})) || die "read error ($!)\n";
		HDR1: {
			if ($self->{_version} == 4) { ($h1, $h2) = unpack('n2', $buf) if ($r == $self->{_data_hlen}); last HDR1 }
			if ($self->{_version} == 5) { ($h1, $h2, $del) = unpack('N2C', $buf) if ($r == $self->{_data_hlen}); last HDR1 }
		}
		if ($h1 == 0) {
			$dseg++;
			$dptr = $self->{_data_start};
			close $fh if ($fh != $self->{_fh});
			$fh = _open_db_segment($self->{_db_fpath}.$self->{_db_fname}, $dseg);
			seek($fh, $self->{_data_start}, SEEK_SET) || die "seek error ($!)\n";
			read($fh, $buf, $self->{_data_hlen}) == $self->{_data_hlen} || die "read error ($!)\n";
			HDR2: {
				if ($self->{_version} == 4) { ($h1, $h2) = unpack('n2', $buf); last HDR2 }
				if ($self->{_version} == 5) { ($h1, $h2, $del) = unpack('N2C', $buf); last HDR2 }
			}
		}
		$del = ($h2 == 0) if ($self->{_version} == 4);
		if ($del) {
			seek($fh, $h1, SEEK_CUR) || die "seek error ($!)\n";
		} else {
			read($fh, $buf, $h1) == $h1 || die "read error ($!)\n";
			$data = [$buf, $h1];
		}
		$dptr += $self->{_data_hlen}+$h1;
		undef $buf;
	} until ($del == 0);
	close $self->{_fh} if ($fh != $self->{_fh});
	$self->{_fh} = $fh;
	$self->{_seg_cur} = $dseg;
	$self->{_data_cur} = $dptr;
	$self->{_rec_cur}++;
	$self->{_rec_cur} = -1 if ($self->{_rec_cur} >= $self->{_rec_tot});

	return $data;
}

#################
## constructor ##
#################
sub new {

	my ($class, $filename) = @_;

	my $self = {
		_err		=> 0,
		_db_fname	=> undef,
		_db_fpath	=> undef,
		_fh			=> undef,
		_rec_tot	=> undef,
		_rec_cur	=> undef,
		_version	=> undef,
		_data_hlen	=> undef,
		_data_cur	=> undef,
		_seg_tot	=> undef,
		_seg_cur	=> undef,
		_seg_size	=> undef,
		_data_start	=> undef,
		_data_end	=> undef,
		_data_keys	=> undef,
	};

	eval {
		my ($buf, $hdr_kcnt, $hdr_zip, $hdr_enc);
		(($self->{_db_fname}, $self->{_db_fpath}) = fileparse($filename)) || die "cannot parse filename\n";
		# open file, segment 0
		$self->{_fh} = _open_db_segment($self->{_db_fpath}.$self->{_db_fname}, 0);
		# read 1st 512 bytes (1 block)
		read($self->{_fh}, $buf, 512) == 512 || die "read failed ($!)\n";
		# check file type and version
        (my $t, $self->{_version}) = unpack('Nn', $buf);
        $t == 0x10121419 || die "wrong file type\n";
		# acquire data area ptr
		DATA_PTR: {
			if ($self->{_version} == 4) { $self->{_data_start} = unpack('N', substr($buf, 0x001e, 4)); last DATA_PTR; }
			if ($self->{_version} == 5) { $self->{_data_start} = unpack('N', substr($buf, 0x0022, 4)); last DATA_PTR; }
			die "unsupported file version\n";
		}
		# read the rest of header
		(read($self->{_fh}, $buf, $self->{_data_start}-512, 512) == $self->{_data_start}-512 || die "read failed ($!)\n") if ($self->{_data_start} > 0);
		# acquire some more infos from header
		READ_HDR: {
			if ($self->{_version} == 4) {
				$self->{_data_hlen} = unpack('n', substr($buf, 0x0054, 2));
				$self->{_seg_tot} = unpack('n', substr($buf, 0x0062, 2))+1;
				$self->{_seg_size} = unpack('N', substr($buf, 0x0066, 4));
				$self->{_data_end} = unpack('N', substr($buf, 0x0018, 4)) +	unpack('n', substr($buf, 0x001c, 2))*$self->{_seg_size};
				$self->{_rec_tot} = unpack('N', substr($buf, 0x0034, 4));
				$hdr_kcnt = unpack('C', substr($buf, 0x0078, 1));
				$hdr_zip = unpack('C', substr($buf, 0x0079, 1));
				$hdr_enc = unpack('C', substr($buf, 0x007a, 1));
				# get keys data
				$self->{_data_keys} = [] if ($hdr_kcnt > 0);
				for my $i (0 .. $hdr_kcnt-1) {
					my $key_segs = unpack('C', substr($buf, 0x00a0+$i*(11+16*3)+7, 1));
					$self->{_data_keys}->[$i] = [] if ($key_segs > 0);
					for my $j (0 .. $key_segs-1) {
						$self->{_data_keys}->[$i]->[$j] = [
							unpack('C', substr($buf, 0x00a0+$i*(11+16*3)+11+$j*3+0, 1)),	# size
							unpack('n', substr($buf, 0x00a0+$i*(11+16*3)+11+$j*3+1, 2))		# offset
						];
					}
				}
				last READ_HDR;
			}
			if ($self->{_version} == 5) {
				$self->{_data_hlen} = unpack('n', substr($buf, 0x0068, 2));
				$self->{_seg_tot} = unpack('n', substr($buf, 0x0076, 2))+1;
				$self->{_seg_size} = unpack('N', substr($buf, 0x007a, 4));
				$self->{_data_end} = unpack('N', substr($buf, 0x001c, 4)) +	unpack('n', substr($buf, 0x0020, 2))*$self->{_seg_size};
				$self->{_rec_tot} = unpack('N', substr($buf, 0x003e, 4));
				$hdr_kcnt = unpack('C', substr($buf, 0x009d, 1));
				$hdr_zip = unpack('C', substr($buf, 0x009e, 1));
				$hdr_enc = unpack('C', substr($buf, 0x009f, 1));
				# get keys data
				$self->{_data_keys} = [] if ($hdr_kcnt > 0);
				for my $i (0 .. $hdr_kcnt-1) {
					my $key_segs = unpack('C', substr($buf, 0x00c2+$i*(10+16*6)+7, 1));
					$self->{_data_keys}->[$i] = [] if ($key_segs > 0);
					for my $j (0 .. $key_segs-1) {
						$self->{_data_keys}->[$i]->[$j] = [
							unpack('n', substr($buf, 0x00c2+$i*(10+16*6)+10+$j*6+0, 2)),	# size
							unpack('N', substr($buf, 0x00c2+$i*(10+16*6)+10+$j*6+2, 4))		# offset
						];
					}
				}
				last READ_HDR;
			}
		}
		# check for unsupported archives
		$hdr_zip == 0 || die "compressed DBs are not supported (yet)\n";
		$hdr_enc == 0 || die "encrypted DBs are not supported (yet)\n";
		# check if all segments files are open-able
		close(_open_db_segment($self->{_db_fpath}.$self->{_db_fname}, $_) || die "some data files are unavailable\n") for (1 .. $self->{_seg_tot}-1);
		# finalize init
		$self->{_rec_cur} = ($self->{_data_start} > 0) ? 0 : -1;
		$self->{_seg_cur} = 0;
		$self->{_data_cur} = $self->{_data_start};
	};
	if ($@) {
		close $self->{_fh} if ($self->{_fh});
		chomp $@;
		$self->{_err} = @_;
		#Carp::carp "Unable to initialize DB: $@";
warn "\n*** $@\n";
		return undef;
	}

	bless ($self, $class);
	return $self;
}

################
## destructor ##
################
sub DESTROY {

	my ($self) = @_;

	_free_vars($self);
}

###############################
# Free object, discard all    #
#   in:	 -                    #
#   out: -                    #
###############################
sub free {

	my ($self) = @_;

	close($self->{_fh});
	_free_vars($self);
}

###################################
# get records counter             #
#   in:	 -                        #
#   out: $scalar (record counter) #
###################################
sub records {

	my $self = shift;
	return $self->{_rec_tot};
}

####################################
# get/set curr.record ptr          #
#   in:	 $recno                    #
#        neg.values count from end #
#   out: $scalar (curr.record)     #
#        undef if error            #
####################################
sub recno {

	my $self = shift;
    if (@_) {
		my $rec = shift;
		$rec += $self->{_rec_tot} if ($rec < 0);
		eval {
			$rec >= 0 || die "requested record is below BOF\n";
			$rec < $self->{_rec_tot} || die "requested record is beyond EOF\n";
			$self->reset if ($rec < $self->{_rec_cur});
			while ($rec > $self->{_rec_cur}) { _read_next($self) }
			#while ($rec > $self->{_rec_cur}) { (my $d = _read_next($self)) || return undef; undef $d }
		};
		if ($@) {
			chomp $@;
			$self->{_err} = $@;
			#Carp::carp "Unable to set recno: $@";
			return undef;
		}
	}
	return $self->{_rec_cur};
}

##################################
# reset records counter          #
#   in:	 -                       #
#   out: $scalar (curr.record=0) #
#        undef if error          #
##################################
sub reset {

	my $self = shift;

	my $fh = $self->{_fh};
	eval {
		$self->{_data_start} > 0 || die "cannot reset on an empty DB\n";
		$fh = _open_db_segment($self->{_db_fpath}.$self->{_db_fname}, 0) if ($self->{_seg_cur} != 0);
		(seek($fh, $self->{_data_start}, SEEK_SET) || die "seek error ($!)\n") if ($self->{_data_start} > 0);
	};
	if ($@) {
		chomp $@;
		$self->{_err} = $@;
		#Carp::carp "Unable to reset recno: $@";
		return undef;
	}
	close $self->{_fh} if ($fh != $self->{_fh});
	$self->{_fh} = $fh;
	$self->{_rec_cur} = ($self->{_data_start} > 0) ? 0 : -1;
	$self->{_seg_cur} = 0;
	$self->{_data_cur} = $self->{_data_start};
	return 0;
}

################################
# get next record              #
#   in:  -                     #
#   out: $record_objref        #
#        undef if error        #
################################
sub next {

	my $self = shift;

	my $rec_ref;
	eval {
		$self->{_data_start} > 0 || die "cannot next on an empty DB\n";
		my $data_ref = _read_next($self);
		$rec_ref = VisionDB::Read::record->new($data_ref);
		undef $data_ref;
	};
	if ($@) {
		chomp $@;
		$self->{_err} = $@;
		#Carp::carp "Unable to read next record: $@";
		return undef;
	}
	return $rec_ref;
}

###############################
# get DB base name            #
#   in:  -                    #
#   out: $scalar (base name)  #
###############################
sub filename {

	my $self = shift;
	return $self->{_db_fname};
}

###############################
# get version number          #
#   in:  -                    #
#   out: $scalar (version)    #
###############################
sub version {

	my $self = shift;
	return $self->{_version};
}

###############################
# get error number            #
#   in:  -                    #
#   out: $scalar (error num.) #
###############################
sub error {

	my $self = shift;
	return $self->{_err};
}

################################
# get fields structure         #
#   in:  -                     #
#   out: $array (fields array) #
################################
sub fields {

	my $self = shift;

    my @f = ();
	foreach my $key (@{$self->{_data_keys}}) {	# each key
		foreach my $seg (@$key) {				# each segment
			my ($len, $off) = @$seg;
			push(@f, $off) if (!exists { map { $_ => 1 } @f }->{$off});
			push(@f, $off+$len) if (!exists { map { $_ => 1 } @f }->{($off+$len)});
		}
	}
	return sort {$a <=> $b} @f;
}

#############################################
# sub-package VisionDB::Read::record        #
#                                           #
# just a data container...                  #
#############################################

package VisionDB::Read::record;

use strict;

our (@ISA, @EXPORT, @EXPORT_OK);

#################
## constructor ##
#################
sub new {

	my ($class, $dataref) = @_;
	my $self = {
		_data	=> $dataref->[0],
		_len	=> $dataref->[1],
	};
	bless($self, $class);
	return $self;
}

################
## destructor ##
################
sub DESTROY {

	my $self = shift;

	undef $self->{_data};
	undef $self->{_len};
}

###############################
# Free object, discard all    #
#   in:	 -                    #
#   out: -                    #
###############################
sub dispose {

	my $self = shift;

	undef $self->{_data};
	undef $self->{_len};
}

###############################
# Get data ref                #
#   in:	 -                    #
#   out: $data_ref            #
###############################
sub data {

	my $self = shift;

	return $self->{_data};
}

###############################
# Get data len                #
#   in:	 -                    #
#   out: $data_len            #
###############################
sub size {

	my $self = shift;

	return $self->{_len};
}

1;
__END__