List::Filter::Storage::DBI - filter storage via DBI

   # This is a plugin, not intended for direct use.
   # See: List:Filter:Storage

   use List::Filter::Storage::DBI;
   my $lfps_dbi = List::Filter::Storage::DBI->new(
         type       => 'filter',
         connect_to => $connect_to,
         owner      => $owner,
         password   => $password,
   );

  List::Filter::Storage::DBI::Pg

package List::Filter::Storage::DBI;
use base qw( List::Filter::StorageBase );

use 5.8.0;
use strict;
use warnings;
use Carp;
use Data::Dumper;
use Hash::Util qw( lock_keys unlock_keys );

our $VERSION = '0.01';

# Note: new is inherited from Class::Base.
# It calls the following "init" routine automatically.

sub init {
  my $self = shift;
  my $args = shift;
  unlock_keys( %{ $self } );

  $self->SUPER::init( $args );  # uncomment if this is a child class

  # Ensure that filter table exists in the database
  $self->create_filter_table;

  lock_keys( %{ $self } );
  return $self;
}

sub create_filter_table {
  my $self = shift;
  my $table = $self->type;

  my $sql =<<"ENDSKULL";
CREATE TABLE $table (
       id             INTEGER PRIMARY KEY,
       name           TEXT UNIQUE,
       terms          TEXT,  --  more portable than "BLOB"?
       method         TEXT,
       description    TEXT,
       modifiers      TEXT
);
ENDSKULL

  $sql .= 'CREATE INDEX idx_' . $table . "_name ON $table (name)\n";

  $self->create_table( $sql );

  return $self;
}

sub create_table {
  my $self       = shift;
  my $create_sql = shift;

  $self->debug("sql: \n$create_sql");

  my $dbh = $self->dbh;


  { # switch off RaiseError setting temporarily
    local $dbh->{RaiseError};
    local $dbh->{PrintError};

    # attempt to create table, ignoring error if it exists already.
    eval {
      $dbh->do( $create_sql )
    };
    if ( ($@) or (my $err = $dbh->err) ) {  # note, with RaiseError off, "err" is tripped, but not $@
      my $errstr = $dbh->errstr;

      # Expected values:
      # err code: 1
      # errstr:   table filter already exists(1)  [...]

      my $mess = "create_filter_table: err code: $err  errstr: $errstr";

      # ignore only the expected error message
      if ( not( (
                 ( $err eq 1 ) &&
                 ( $errstr =~ m{ table \s+ (.*?) \s+ already \s+ exists }x )
                )
              )          ) {
        croak "Error: $mess";

        $self->debug( "Warning: $mess" );
      }
    }
  }
  return $self;
}

sub init_dbh {
  my $self = shift;

  my $connect_to   = $self->connect_to;
  my $owner        = $self->owner;
  my $password     = $self->password;
  my $attributes    = $self->attributes;

  my $dbh = DBI->connect($connect_to, $owner, $password, $attributes)
    or croak "Database connection failed: $connect_to";

  $self->set_dbh( $dbh );
  return $dbh;
}

sub lookup {
  my $self = shift;
  my $name = shift;

  my $table = $self->type;
  my $sql = "SELECT terms, method, description, modifiers FROM $table WHERE name = ?";
  my $dbh = $self->dbh;
  my $sth = $dbh->prepare($sql);
  $sth->execute( $name );
  my $row = $sth->fetchrow_arrayref;

  my $terms_serialized = $row->[0];
  my $method      = $row->[1];
  my $description = $row->[2];
  my $modifiers   = $row->[3];

  # Unpacking aref serialized with Data::Dumper->Dump
  my $terms;
  eval $terms_serialized;

  # create a filter object
  my $filter_class = $self->define_filter_class;
  my $filter = $filter_class->new(
     { name         => $name,
       terms        => $terms,
       method       => $method,
       description  => $description,
       modifiers    => $modifiers,
     } );

   return $filter;
}

sub save {
  my $self    = shift;
  my $filter  = shift;

  my $dbh = $self->dbh;

  my $name         = $filter->name;

  if ($name =~ m{^_}x) {
    return;
  } else {
    $self->debug("Refusing to save filter named with leading underscore: $name");
  }

  my $method       = $filter->method;
  my $description  = $filter->description;
  my $modifiers    = $filter->modifiers;
  my $terms        = $filter->terms;

  my $terms_serialized
    = Data::Dumper->Dump( [$terms], ['terms'] );

  my $table = $self->type;

  my $sql =
    "INSERT INTO $table (name, terms, method, description, modifiers)
          VALUES (?, ?, ?, ?, ?)";

  my $sth = $dbh->prepare( $sql );
  $sth->execute( $name,
                 $terms_serialized,
                 $method,
                 $description,
                 $modifiers );

  if ($dbh->err) {
    my $errstr = $dbh->errstr;
    carp "save: problem on INSERT: $errstr "
  }

  return $filter;
}

sub list_filters {
  my $self = shift;

  my $table = $self->type;
  my $sql = "SELECT name FROM $table";
  my $dbh = $self->dbh;
  my $sth = $dbh->prepare($sql);
  $sth->execute();
  my $row = $sth->fetchrow_arrayref;

  return $row;
}

sub dbh {
  my $self = shift;
  my $dbh = $self->extra->{ dbh };

  if ( not( $dbh ) ) {
    $dbh = $self->init_dbh;
  }

  return $dbh;
}

sub set_dbh {
  my $self = shift;
  my $dbh = shift;
  $self->extra->{ dbh } = $dbh;
  return $dbh;
}

1;