# I'm not sure whether to use now
package PseudoDBM;
use Carp qw/carp/;
#use strict; # PseudoDBM will work with these two, but for
#use warnings; # nasty-ISP environments we rather expect no u
+p-to-date pragma
use vars '$VERSION';
$VERSION = 0.5;
use Fcntl ':flock';
use IO::File;
#
# super-simplified
# eval { flock } would be much better...
use constant CAN_FLOCK => $^O !~ /Win|VMS/;
sub TIEHASH {
my $c = shift;
$c = ref $c || $c;
my $fname = shift or carp("no filename given."),return;
my ($kln,$vln);
$kln = shift || 100;
if(ref $kln and ref $kln eq 'HASH') {
my %opt = %$kln;
$kln = $opt{'key_length'};
$vln = $opt{'val_length'} || $kln || 100;
$kln = $kln || $vln || 100;
} else {
$vln = shift || 100;
}
-e $fname or carp("'$fname' does'nt exist."),return;
-f $fname or carp("'$fname' isn't a file."),return;
-R $fname or carp("'$fname' is not readable."),return;
-W $fname or carp("'$fname' is not writeable."),return;
my $self = {};
$self->{'fh'} = new IO::File;
$self->{'fh'}->open("+<$fname") or carp("couldn't open '$fname
+': $!"),return;
flock $self->{'fh'},LOCK_EX if CAN_FLOCK;
# cheap idiom? autoflush the handle
select(
( select($self->{'fh'}), $|=1) [0]
);
$self->{'fn'} = $fname;
$self->{'kln'} = $kln;
$self->{'vln'} = $vln;
$self->{'ip'} = 0; #iterating position, see FIRSTKEY and LASTK
+EY
$self->{'fh'}->seek(0,0);
bless $self,$c;
}
sub UNTIE {
my $self = shift;
$self->{'fh'}->close;
}
sub FETCH {
my ($self,$getkey) = @_;
my ($kln,$vln) = @{$self}{'kln','vln'};
my ($record,$key,$val,$found);
while( read( $self->{'fh'} , $record , $kln+$vln ) ) {
($key,$val) = unpack("A$kln A$vln",$record);
if($key eq $getkey) {
$found = $val;
last;
}
}
$self->{'fh'}->seek(0,0);
return defined $found ? $found : undef;
}
sub STORE {
my ($self,$getkey,$nvalue) = @_;
my ($kln,$vln) = @{$self}{'kln','vln'};
carp("too long key '$getkey'"),return if length($getkey) > $kl
+n;
carp("too long value '$nvalue'"),return if length($nvalue) > $
+vln;
my ($record,$key,$oldval,$pos);
my $flag = 0;
while( read( $self->{'fh'} , $record , $kln+$vln ) ) {
($key,$oldval) = unpack("A$kln A$vln",$record);
if($key eq $getkey) {
$self->{'fh'}->seek( -($kln+$vln) , 1 );
$self->{'fh'}->print( pack("A$kln A$vln",$key,
+$nvalue) );
$flag = 1;
last;
}
}
unless($flag ) {
$self->{'fh'}->seek( 0 , -1 );
$self->{'fh'}->print( pack("A$kln A$vln",$getkey,$nval
+ue) );
}
$self->{'fh'}->seek(0,0);
return defined $oldval ? $oldval : 1;
}
sub DELETE {
my ($self,$getkey) = @_;
my ($kln,$vln) = @{$self}{'kln','vln'};
my ($record,$key,$val,);
my $key_found = 0;
while( read( $self->{'fh'} , $record , $kln+$vln ) ) {
($key,$val) = unpack("A$kln A$vln",$record);
if($key eq $getkey) {
#found the key
$key_found = 1;
last;
}
}
# if we found the key, we're at position after the set to find
$record = '';
if( $key_found ) {
#so we read out 1 set
while( read( $self->{'fh'} , $record , $kln+$vln ) ) {
#seek back 2 sets
$self->{'fh'}->seek( -2*($kln+$vln) , 1 );
#and print the set
$self->{'fh'}->print( $record );
#and go 1 ahead
$self->{'fh'}->seek( ($kln+$vln)*2 , 1 );
}
#delete last set here:
# seek to wanted
$self->{'fh'}->seek( -($kln+$vln) , 1 );
$self->{'fh'}->truncate( $self->{'fh'}->tell );
$self->{'fh'}->seek(0,0);
return 1;
}
$self->{'fh'}->seek(0,0);
$val
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~
sub CLEAR {
my ($self) = @_;
$self->{'fh'}->truncate(0);
$self->{'fh'}->seek(0,0);
return ();
}
sub EXISTS {
my ($self,$getkey) = @_;
my ($kln,$vln) = @{$self}{'kln','vln'};
my ($record,$key,$val);
my $found = 0;
while( read( $self->{'fh'} , $record , $kln+$vln ) ) {
($key,$val) = unpack("A$kln A$vln",$record);
if( $key eq $getkey ){
$found = 1;
last;
}
}
$self->{'fh'}->seek(0,0);
return $found ? 1 : undef;
}
sub FIRSTKEY {
my ($self) = @_;
my ($kln,$vln) = @{$self}{'kln','vln'};
my ($record,$key,$val);
read( $self->{'fh'} , $record , $kln+$vln );
($key,$val) = unpack("A$kln A$vln",$record);
$self->{'ip'} = $self->{'fh'}->tell;
$self->{'fh'}->seek(0,0);
return $key;#,$val);
}
sub NEXTKEY {
my ($self,$bk) = @_;
$self->{'fh'}->seek( $self->{'ip'} , 0);
my ($kln,$vln) = @{$self}{'kln','vln'};
my ($record,$key,$val);
read( $self->{'fh'} , $record , $kln+$vln ) or do { $self->{'f
+h'}->seek(0,0); return };
($key,$val) = unpack("A$kln A$vln",$record);
$self->{'ip'} = $self->{'fh'}->tell;
$self->{'fh'}->seek(0,0);
return $key;#,$val);
}
sub DESTROY {
UNTIE(@_);
}
1;
=pod
=head1 NAME
PseudoDBM - pure Perl Hash-tie()ing to fixed-length-record-text-files
=head1 SYNOPSIS
tie %hash , 'PseudoDBM' , 'file' ,{'key_length'=>20,'val_length'=>150
+};
...
untie %hash;
=head1 DESCRIPTION
=head2 tie()
use the Perl-tie() function with the following arguments:
=over 4
=item The hash you want to tie
=item The string 'PseudoDBM'
=item The File you want to tie
=item the length of keys in the File
=item the length of values in the File
=back
Instead of the last two arguments, you can use a hashref with the key
+'key_length' for the
length of keys and 'val_length' for the value-length.
The tie() will open the File and flock() it exclusively until the hash
+ is untied or deleted.
=back
=head2 inside
Keys and Values are stored in fixed-length fields, which makes these f
+iles readable.
You mustn't assign longer keys or values than specified with the tieha
+sh-call.
=head2 untie
untie closes the file (= takes away lock).
The return value is the return value of close(), so if it's fails, see
+ $! for details.
=head1 BUGS / WHAT'S THIS GOOD FOR
The module is surely not very fast. I wrote it for use on Nasty-ISP-We
+bspace where no real
DBM is available. You should not use this in important programs.
The error handling is rather imperfect: PseudoDBM will carp() error me
+ssages and return whenever something fails.
That's another reason only to use this module in development, because
+it makes it hard to keep control of STDERR.
=head1 AUTHOR
Richard Voß <info@fruiture.de>
=cut
# i wasn't sure whether to use
here |
