New Module Idea: MLDBM::Sync

[Joshua Chamas]

Hey,

I'm working on a new module to be used for mod_perl style 
caching.  I'm calling it MLDBM::Sync because its a subclass 
of MLDBM that makes sure concurrent access is serialized with 
flock() and i/o flushing between reads and writes.  Below is 
the code for the module.  I believe it could be used too as a 
safe backing store for Memoize in a multi-process environment.

It could be used like:

  tie %mldbm, 'MLDBM::Sync', '/tmp/mldbm_dbm', O_CREAT|O_RDWR, 0666;
  $mldbm{rand()} = [ rand() ];
  %mldbm = ();

The history is that I hunted around for on disk caching in 
which I can stuff db query results temporarily, and the best I 
liked was File::Cache, which is really cool BTW.  I would use it, 
but MLDBM::Sync using default SDBM_File seems to be 2 to 3 times 
faster, getting about 1000 writes / sec on my dual PIII 400.

MLDBM::Sync using MLDBM in DB_File mode is considerably slower 
than File::Cache, by 5-10 times, so it really depends on the
data you want to store, for which you might use.  The 1024 byte
limit on SDBM_File makes it often not the right choice.

I also thought about calling it MLDBM::Lock, MLDBM::Serialize, 
MLDBM::Multi ... I like MLDBM::Sync though.  For modperl
caching usage, I imagine tieing to it in each child, and clearing
when necessary, perhaps even at parent httpd initialization...
no auto-expiration here, use File::Cache, IPC::Cache for that!

Any thoughts? 

--Joshua

_________________________________________________________________
Joshua Chamas                           Chamas Enterprises Inc.
NodeWorks >> free web link monitoring   Huntington Beach, CA  USA 
http://www.nodeworks.com                1-714-625-4051

package MLDBM::Sync;
use MLDBM;
use Fcntl qw(:flock);
use strict;
no strict qw(refs);
use vars qw($AUTOLOAD);

sub TIEHASH { 
    my($class, $file, @args) = @_;

    my $fh = "$file.lock";
    open($fh, ">>$fh") || die("can't open file $fh: $!");

    bless { 
           'args' => [ $file, @args ],
           'lock' => $fh,
           'keys' => [],
          };
}

sub DESTROY { 
    my $self = shift;
    if (($self->{lock})) {
        close($self->{lock})
    }
}

sub AUTOLOAD {
    my $self = shift;
    $AUTOLOAD =~ /::([^:]+)$/;
    my $func = $1;
    $self->exlock;
    my $rv = $self->{dbm}->$func(@_);
    $self->unlock;
    $rv;
}

sub STORE { 
    my $self = shift;
    $self->exlock;
    my $rv = $self->{dbm}->STORE(@_);
    $self->unlock;
    $rv;
};

sub FETCH { 
    my $self = shift;
    $self->shlock;
    my $rv = $self->{dbm}->FETCH(@_);
    $self->unlock;
    $rv;
};

sub FIRSTKEY {
    my $self = shift;
    $self->shlock;
    $self->{keys} = [ keys %{$self->{dbm_hash}} ];
    $self->unlock;
    $self->NEXTKEY;
}

sub NEXTKEY {
    shift(@{shift->{keys}});
}

sub mldbm_tie {
    my $self = shift;
    my $args = $self->{args};
    my %dbm_hash;
    my $dbm = tie(%dbm_hash, 'MLDBM', @$args) || die("can't tie to MLDBM with args: 
".join(',', @$args)."; error: $!");
    $self->{dbm_hash} = \%dbm_hash;
    $self->{dbm} = $dbm;
}

sub exlock {
    my $self = shift;
    flock($self->{lock}, LOCK_EX) || die("can't write lock $self->{lock}: $!");
    $self->mldbm_tie;
}

sub shlock {
    my $self = shift;
    flock($self->{lock}, LOCK_SH) || die("can't share lock $self->{lock}: $!");
    $self->mldbm_tie;
}

sub unlock {
    my $self = shift;
    undef $self->{dbm};
    untie %{$self->{dbm_hash}};
    flock($self->{lock}, LOCK_UN) || die("can't unlock $self->{lock}: $!");
}

---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]