File Coverage

blib/lib/Bot/BasicBot/Pluggable/Store/DBI.pm

Criterion	Covered	Total	%
statement	106	113	93.8
branch	20	36	55.5
condition	6	9	66.6
subroutine	18	19	94.7
pod	6	9	66.6
total	156	186	83.8

package Bot::BasicBot::Pluggable::Store::DBI;
$Bot::BasicBot::Pluggable::Store::DBI::VERSION = '1.11';
use warnings;
use strict;
use Carp qw( croak );
use Data::Dumper;
use DBI;
use Storable qw( nfreeze thaw );
use Try::Tiny;

use base qw( Bot::BasicBot::Pluggable::Store );

sub init {
    my $self = shift;
    $self->{dsn}   ||= 'dbi:SQLite:bot-basicbot.sqlite';
    $self->{table} ||= 'basicbot';
    $self->create_table;
}

sub dbh {
    my $self     = shift;
    my $dsn      = $self->{dsn} or die "I need a DSN";
    my $user     = $self->{user};
    my $password = $self->{password};
    return DBI->connect_cached( $dsn, $user, $password );
}

sub create_table {
    my $self  = shift;
    my $table = $self->{table} or die "Need DB table";
    my $sth   = $self->dbh->table_info( '', '', $table, "TABLE" );

	$table = $self->dbh->quote_identifier($table);

    if ( !$sth->fetch ) {
        $self->dbh->do(
            "CREATE TABLE $table (
			    			    id INT PRIMARY KEY,
			    			    namespace TEXT,
			    			    store_key TEXT,
			    			    store_value LONGBLOB )"
        );
        if ( $self->{create_index} ) {
            try {
                $self->dbh->do(
"CREATE INDEX lookup ON $table ( namespace(10), store_key(10) )"
                );
            };
        }
    }
}

sub get {
    my ( $self, $namespace, $key ) = @_;
    my $table = $self->{table} or die "Need DB table";

	$table = $self->dbh->quote_identifier($table);

    my $sth = $self->dbh->prepare_cached(
        "SELECT store_value FROM $table WHERE namespace=? and store_key=?");
    $sth->execute( $namespace, $key );
    my $row = $sth->fetchrow_arrayref;
    $sth->finish;
    return unless $row and @$row;
    return try { thaw( $row->[0] ) } catch { $row->[0] };
}

sub set {
    my ( $self, $namespace, $key, $value ) = @_;
    my $table = $self->{table} or die "Need DB table";

	$table = $self->dbh->quote_identifier($table);

    $value = nfreeze($value) if ref($value);
    if ( defined( $self->get( $namespace, $key ) ) ) {
        my $sth = $self->dbh->prepare_cached(
            "UPDATE $table SET store_value=? WHERE namespace=? AND store_key=?"
        );
        $sth->execute( $value, $namespace, $key );
        $sth->finish;
    }
    else {
        my $sth = $self->dbh->prepare_cached(
"INSERT INTO $table (id, store_value, namespace, store_key) VALUES (?, ?, ?, ?)"
        );
        $sth->execute( $self->new_id($table), $value, $namespace, $key );
        $sth->finish;
    }
    return $self;
}

sub unset {
    my ( $self, $namespace, $key ) = @_;
    my $table = $self->{table} or die "Need DB table";

	$table = $self->dbh->quote_identifier($table);

    my $sth = $self->dbh->prepare_cached(
        "DELETE FROM $table WHERE namespace=? and store_key=?");
    $sth->execute( $namespace, $key );
    $sth->finish;
}

sub new_id {
    my $self  = shift;
    my $table = shift;
    my $sth   = $self->dbh->prepare_cached("SELECT MAX(id) FROM $table");
    $sth->execute();
    my $id = $sth->fetchrow_arrayref->[0] || "0";
    $sth->finish();
    return $id + 1;
}

sub keys {
    my ( $self, $namespace, %opts ) = @_;
    my $table = $self->{table} or die "Need DB table";

	$table = $self->dbh->quote_identifier($table);

    my @res = ( exists $opts{res} ) ? @{ $opts{res} } : ();

    my $sql = "SELECT store_key FROM $table WHERE namespace=?";

    my @args = ($namespace);

    foreach my $re (@res) {
        my $orig = $re;

        # h-h-h-hack .... convert to SQL and limit terms if too general
        $re = "%$re"               if $re !~ s!^\^!!;
        $re = "$re%"               if $re !~ s!\$$!!;
        $re = "${namespace}_${re}" if $orig =~ m!^[^\^].*[^\$]$!;

        $sql .= " AND store_key LIKE ?";
        push @args, $re;
    }
    if ( exists $opts{limit} ) {
        $sql .= " LIMIT ?";
        push @args, $opts{limit};
    }

    my $sth = $self->dbh->prepare_cached($sql);
    $sth->execute(@args);

    return $sth->rows if $opts{_count_only};

    my @keys = map { $_->[0] } @{ $sth->fetchall_arrayref };
    $sth->finish;
    return @keys;
}

sub namespaces {
    my ($self) = @_;
    my $table = $self->{table} or die "Need DB table";

	$table = $self->dbh->quote_identifier($table);

    my $sth =
      $self->dbh->prepare_cached("SELECT DISTINCT namespace FROM $table");
    $sth->execute();
    my @keys = map { $_->[0] } @{ $sth->fetchall_arrayref };
    $sth->finish;
    return @keys;
}

1;

__END__

=head1 NAME

Bot::BasicBot::Pluggable::Store::DBI - use DBI to provide a storage backend

=head1 VERSION

version 1.11

=head1 SYNOPSIS

  my $store = Bot::BasicBot::Pluggable::Store::DBI->new(
    dsn          => "dbi:mysql:bot",
    user         => "user",
    password     => "password",
    table        => "brane",

    # create indexes on key/values?
    create_index => 1,
  );

  $store->set( "namespace", "key", "value" );

=head1 DESCRIPTION

This is a L<Bot::BasicBot::Pluggable::Store> that uses a database to store
the values set by modules. Complex values are stored using Storable.

=head1 AUTHOR

Mario Domgoergen <[e-mail]>

This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.