[FWP] SQL_File - as in SQL version of DB_File

[matija.grabnar@arnes.si]

Just for fun I wrote an Any_DBM compatible SQL module, i.e. a module you can
use instead of any of the DB_* modules to tie a hash to a database.

It's not as fast as DB_File, when used with MySQL, but it is a way to unload
some of the burden on another machine when you have a ludicorously large
hashes.

#
# SQL_File.pm -- Perl5 DB interface to SQL databases
#

package SQL_File;
use DBI;

use strict;
 
sub TIEHASH {
    my $self = shift;
    my ($data_source,$mode,$dbname,$username,$auth,$attr_ref)=@_;
    unless ($data_source=~/^DBI:/) {
        $dbname=$data_source;
        $data_source="DBI:mysql:test:localhost";
    }
    $mode="";                                     # mode is currently ignored
    my $dbh=DBI->connect($data_source, $username, $auth, $attr_ref);
    $dbname=~s![./]!_!g;
    
    my $node= {};
    $node->{INSERT}=($dbh->prepare("INSERT into $dbname values (?,?)") 
                     || die $dbh->errstr);
    $node->{DELETE}=($dbh->prepare("DELETE from $dbname where tbl_key = ?") 
                     || die $dbh->errstr);
    $node->{EACH}=($dbh->prepare("select tbl_key from $dbname")
                   || die $dbh->errstr);
    $node->{FETCH}=($dbh->prepare("select tbl_val from $dbname where tbl_key=?")
                    || die $self->DB->errstr);
    $node->{CLEAR}=($dbh->prepare("delete from $dbname")
                      || die $self->DB->errstr);
    eval q(
           local $dbh->{RaiseError} = 1 if !$dbh->{RaiseError};
           local $dbh->{PrintError} = 0 if $dbh->{PrintError};
           $dbh->do("create table $dbname (tbl_key varchar(255) ".
                    "primary key, tbl_val blob)") 
           || die $dbh->errstr );
    die $@ if ($@ && $@!~/already exists/);
    return bless $node, $self;
}

sub STORE {
    my ($self,$key,$value)=@_;
    $self->{DELETE}->execute($key);
    $self->{INSERT}->execute($key,$value);
}

sub FIRSTKEY {
    my ($self)=@_;
    $self->{EACH}->execute;
    my $ary_ref  = $self->{EACH}->fetchrow_arrayref;
    return $$ary_ref[0];
}

sub NEXTKEY {
    my ($self)=@_;
    my $ary_ref  = $self->{EACH}->fetchrow_arrayref;
    return $$ary_ref[0];
}

sub FETCH {
    my ($self,$key)=@_;
    $self->{FETCH}->execute($key);
    my $ary_ref = $self->{FETCH}->fetchrow_arrayref;
    return $$ary_ref[0];
}

sub EXISTS {
    my ($self,$key)=@_;
    $self->{FETCH}->execute($key);
    my $ary_ref = $self->{FETCH}->fetchrow_arrayref;
    return defined($$ary_ref[0]);
}

sub DELETE {
    my ($self,$key)=@_;
    $self->{DELETE}->execute($key);
}

sub CLEAR {
    my ($self)=@_;
    $self->{CLEAR}->execute;
}
1;

==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe