view release on metacpan or  search on metacpan

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

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.48

=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,