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
[download]