File Coverage

blib/lib/Class/PObject/Driver/db_file.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Class::PObject::Driver::db_file;

# $Id: db_file.pm,v 1.5 2003/11/07 04:43:14 sherzodr Exp $

use strict;
#use diagnostics;
use vars ('$VERSION', '@ISA');
use Carp;
use DB_File;
use Class::PObject::Driver::DBM;

@ISA = ('Class::PObject::Driver::DBM');

$VERSION = '2.01';

sub dbh {
    my ($self, $object_name, $props, $lock_type) = @_;

    my $filename = $self->_filename($object_name, $props);
    my ($DB, %dbh, $unlock);
    $unlock = $self->_lock($filename, $lock_type||'r') or return undef;
    unless ( $DB = tie %dbh, "DB_File", $filename, O_RDWR|O_CREAT, 0600 ) {
        $self->errstr("couldn't connect to '$filename': $!");
        return undef
    }

    return ($DB, \%dbh, $unlock)
}




sub drop_datasource {
    my ($self, $object_name, $props) = @_;

    my (undef, $dbh, $unlock) = $self->dbh($object_name, $props, 'w') or return;
    my $filename = $self->_filename($object_name, $props);
    unless ( unlink $filename ) {
        $self->errstr( "couldn't unlink '$filename': $!" );
        return undef
    }
    $unlock->();
    return 1
}





sub _filename {
    my ($self, $object_name, $props) = @_;


    my $dir = $self->_dir($props);
    my $filename = lc $object_name;
    $filename    =~ s/\W+/_/g;

    return File::Spec->catfile($dir, $filename . '.dbm')
}



sub _dir {
    my ($self, $props) = @_;

    my $dir = $props->{datasource} || File::Spec->tmpdir();
    unless ( -e $dir ) {
        require File::Path;
        File::Path::mkpath($dir) or die $!
    }
    return $dir
}



1;
__END__