view release on metacpan or  search on metacpan

lib/Bot/IRC/Store/SQLite.pm  view on Meta::CPAN

package Bot::IRC::Store::SQLite;
# ABSTRACT: Bot::IRC persistent data storage with SQLite

use 5.016;
use exact;

use DBI;
use DBD::SQLite;
use JSON::XS;

our $VERSION = '1.49'; # VERSION

sub init {
    my ($bot) = @_;
    my $obj = __PACKAGE__->new($bot);

    $bot->subs( 'store' => sub { return $obj } );
    $bot->register('Bot::IRC::Store');
}

sub new {
    my ( $class, $bot ) = @_;

    my $conf = $bot->vars('store') || 'store.sqlite';
    $conf = { file => $conf } unless ( ref $conf eq 'HASH' );

    my $self = bless( $conf, $class );
    $self->{json} = JSON::XS->new->ascii;

    return $self;
}

sub _dbh {
    my ($self) = @_;
    my $pre_exists = ( -f $self->{file} ) ? 1 : 0;

    my $dbh = DBI->connect(
        'dbi:SQLite:dbname=' . $self->{file},
        undef,
        undef,
        {
            PrintError                   => 0,
            RaiseError                   => 1,
            sqlite_see_if_its_a_number   => 1,
            sqlite_defensive             => 1,
            sqlite_extended_result_codes => 1,
            sqlite_string_mode           => 6,
                # 4 = DBD_SQLITE_STRING_MODE_UNICODE_NAIVE
                # 5 = DBD_SQLITE_STRING_MODE_UNICODE_FALLBACK
                # 6 = DBD_SQLITE_STRING_MODE_UNICODE_STRICT
            %{ $self->{attr} // {} },
        },
    ) or die "$@\n";

    my $pragma = {
        encoding           => '"UTF-8"',
        foreign_keys       => 'ON',
        journal_mode       => 'DELETE',
        recursive_triggers => 'ON',
        synchronous        => 'FULL',
        temp_store         => 'MEMORY',
        %{ $self->{pragma} // {} },
    };
    $dbh->do( 'PRAGMA ' . $_ . ' = ' . $pragma->{$_} ) for ( keys %$pragma );

    $dbh->do(q{
        CREATE TABLE IF NOT EXISTS bot_store (
            bot_store_id INTEGER PRIMARY KEY,
            namespace    TEXT,
            key          TEXT,
            value        TEXT,
            created      TEXT NOT NULL DEFAULT ( STRFTIME( '%Y-%m-%d %H:%M:%f', 'NOW', 'LOCALTIME' ) )
        )
    }) unless ($pre_exists);

    return $dbh;
}

sub get {
    my ( $self, $key ) = @_;
    my $namespace = ( caller() )[0];
    my $value;

    $self->{dbh} //= $self->_dbh;

    try {
        my $sth = $self->{dbh}->prepare_cached(q{
            SELECT value FROM bot_store WHERE namespace = ? AND key = ?
        });
        $sth->execute( $namespace, $key ) or die $self->{dbh}->errstr;
        $value = $sth->fetchrow_array;
        $sth->finish;
    }
    catch ($e) {
        warn "Store get error with $namespace (likely an IRC::Store::SQLite issue); key = $key; error = $e\n";
    }

    if ($value) {
        $value = $self->{json}->decode($value) || undef;
        $value = $value->{value} if ( ref $value eq 'HASH' and exists $value->{value} );
    }

    return $value;
}

sub set {
    my ( $self, $key, $value ) = @_;
    my $namespace = ( caller() )[0];

    $self->{dbh} //= $self->_dbh;

    try {
        $self->{dbh}->begin_work;

        $self->{dbh}->prepare_cached(q{
            DELETE FROM bot_store WHERE namespace = ? AND key = ?
        })->execute( $namespace, $key ) or die $self->{dbh}->errstr;

        $self->{dbh}->prepare_cached(q{
            INSERT INTO bot_store ( namespace, key, value ) VALUES ( ?, ?, ? )
        })->execute(
            $namespace,
            $key,
            $self->{json}->encode( { value => $value } ),
        ) or die $self->{dbh}->errstr;

        $self->{dbh}->commit;
    }
    catch ($e) {
        $self->{dbh}->rollback;
        warn "Store set error with $namespace (likely an IRC::Store::SQLite issue); key = $key; error = $e\n";
    }

    return $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Bot::IRC::Store::SQLite - Bot::IRC persistent data storage with SQLite

=head1 VERSION

version 1.49

=head1 SYNOPSIS

    use Bot::IRC;

    Bot::IRC->new(
        connect => { server => 'irc.perl.org' },
        plugins => ['Store::SQLite'],
        vars    => {
            store => {
                file => 'store.sqlite',
                attr => {
                    PrintError                   => 0,
                    RaiseError                   => 1,
                    sqlite_see_if_its_a_number   => 1,
                    sqlite_defensive             => 1,
                    sqlite_extended_result_codes => 1,
                    sqlite_string_mode           => 6,
                },
                pragma => {
                    encoding           => '"UTF-8"',
                    foreign_keys       => 'ON',
                    journal_mode       => 'DELETE',
                    recursive_triggers => 'ON',
                    synchronous        => 'FULL',
                    temp_store         => 'MEMORY',
                },
            },
        },
    )->run;

=head1 DESCRIPTION

This L<Bot::IRC> plugin provides a persistent storage mechanism with a SQLite
database file. By default, it's the "store.sqlite" file, but this can be changed
with the C<vars>, C<store> value (as in the above synopsis).

=head1 EXAMPLE USE

This plugin adds a single sub to the bot object called C<store()>. Calling it
will return a storage object which itself provides C<get()> and C<set()>
methods. These operate just like you would expect.

=head2 set

    $bot->store->set( user => { nick => 'gryphon', score => 42 } );

=head2 get

    my $score = $bot->store->set('user')->{score};

=head2 SEE ALSO

L<Bot::IRC>

=for Pod::Coverage init new

=head1 AUTHOR

Gryphon Shafer <gryphon@goldenguru.com>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2016-2050 by Gryphon Shafer.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut