/usr/local/CPAN/CDB_Perl/CDB_Perl/Read.pm

• package CDB_Perl::Read
  • new
  • get_value
  • get_values
  • get_next
  • get_table
  • entry
  • read
  • read_long
  • TIEHASH
  • FETCH
  • STORE
  • EXISTS
  • FIRSTKEY
  • NEXTKEY
  • DELETE
  • DESTROY
• EOF

package CDB_Perl::Read;

use Carp qw(carp croak);

require CDB_Perl;
@ISA = qw(CDB_Perl);

use strict;
#use warnings;

sub new{
	my ($pack, $fname, $cache) = @_;

	if(!$pack or ref($pack)){
		croak "Invalid constructor parameter";
	}
	
	#by default cache is on
	if(!defined($cache)){
		$cache = 1;
	}
	if(!-e $fname){
		croak "$fname doesn't exist";
	}
	if(!-r $fname){
		croak "$fname isn't readable";
	}
	my $size = -s $fname;
	if($size < 2048){
		croak "invalid file ($size < 2048 bytes)";
	}
	my $self = bless {},$pack;
	$self->file_open($fname, '<');
	$self->{'cache'} = $cache;

	if($cache){
		$self->{'tables'} = {};
	}
	return $self;
}

sub get_value{
	if(wantarray){
		return &get_values(@_);
	}
	my ($self, $key) = @_;

	if(!defined($key)){
		croak "key must be defined";
	}

	my($h,$h0,$h1) = $self->hash($key);
	
	my $iter = {
		key  => $key,
		hash => $h,
		tnum => $h0,
		pos  => $h1,
	};

	$self->{'iter'} = $iter;
	return $self->get_next();
}

#compatibility with CDB_File
*multi_get = \&get_values;

sub get_values{
	my $self = shift;
	my $val = $self->get_value(@_);
	my @rsp = ();

	if(defined($val)){
		@rsp = ($val);
		while(defined($val = $self->get_next)){
			push @rsp,$val;
		}
	}
	return @rsp;
}

sub get_next{
	my $self = shift;

	my $iter = $self->{'iter'};
	if(not defined $iter){
		croak "Can't call get_next without having called get_value";
	}

	my $table = $self->get_table($iter->{'tnum'});
	my $len = @$table/2;
	if(!$len){
		return;
	}

	#now iterate
	for(;;){
		$iter->{'pos'} %= $len;
		my($hash,$pos) = (
			$table->[2*$iter->{'pos'}] ,
			$table->[2*++$iter->{pos} -1]
		);

		if($pos == 0){
			return;
		}
		if($hash == $iter->{'hash'}){
			my ($key, $val) = $self->entry($pos);
			if ($key eq $iter->{'key'}){
				return $val;
			}
		}
	}
}

sub get_table{
	my ($self, $n) = @_;

	if(!defined($n)){
		die "table number not defined";
	}

	my $cache = $self->{'cache'};

	if($cache && (exists($self->{'tables'}->{$n}))){
		return $self->{'tables'}->{$n};
	}

	#position in the header
	$self->seek(8*$n);
	my($pos,$len) = $self->read_long(2);

	$self->seek($pos);
	my @table = $self->read_long(2*$len);

	if($cache){
		$self->{'tables'}->{$n} = \@table;
	}

	return \@table;
}

sub entry{
	my ($self, $pos) = @_;

	if($pos < 2048){
		die "pos $pos is invalid";
	}

	$self->seek($pos);
	my ($klen, $vlen) = $self->read_long(2);
	return ((map{$self->read($_)}($klen,$vlen)), $klen, $vlen);
}

sub read{
	my ($self, $len) = @_;

	if(!defined($len)){
		die "Can't read an undefined number of characters.";
	}

	my $data;
	read($self->{'file'},$data,$len) or die "Error reading file";
	#pos not updated
	return $data;
}

sub read_long{
	my ($self, $len) = @_;
	
	if($len == 0){
		return ();
	}

	return unpack("V$len",$self->read($len*4));
}

###############################
# Tied hash interface follows #
###############################

sub TIEHASH{
	my $pack = shift;
	return $pack->new(@_);
}

sub FETCH{
	my ($self, $key) = @_;

	my $lkey = $self->{'tie'}->{'lastkey'};
	my $lval = $self->{'tie'}->{'lastvalue'};
	if(defined($lkey) && $key eq $lkey and defined($lval)){
		return $lval;
	}else{
		my $value = $self->get_value($key);
		return $value;
	}
}

sub STORE{
	croak "Can't store data on a readonly CDB";
}

sub EXISTS{
	my ($self, $key) = @_;

	return defined($self->get_value($key));
}

sub FIRSTKEY{
	my $self = shift;
	$self->{'tie'}->{'iterate_pos'} = 2048;
	#this could break on 'weird' CDB files
	$self->seek(0);
	$self->{'tie'}->{'max_pos'} = ($self->read_long(1))[0];

	delete($self->{'tie'}->{'lastkey'});
	delete($self->{'tie'}->{'lastvalue'});

	return $self->NEXTKEY;
}

sub NEXTKEY{
	my $self = shift;
	#don't need the previous key

	my $pos = \$self->{'tie'}->{'iterate_pos'};
	return unless $$pos < $self->{'tie'}->{'max_pos'};

	my ($key,$val, $klen, $vlen) = $self->entry($$pos);
	$$pos += $klen + $vlen + 8;

	$self->{'tie'}->{'lastkey'} = $key;
	$self->{'tie'}->{'lastvalue'} = $val;

	return $key;
}

sub DELETE{
	croak "Can't delete data on a readonly CDB";
}
*CLEAR = \&DELETE;

sub DESTROY{
	my $self = shift;
	close($self->{'file'}) or croak "Error closing CDB file.\n$!";
}

1;