lib/DBM/Deep/Storage/DBI.pm

   1 package DBM::Deep::Storage::DBI;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use base 'DBM::Deep::Storage';
   9
  10 use DBI;
  11
  12 sub new {
  13     my $class = shift;
  14     my ($args) = @_;
  15
  16     my $self = bless {
  17         autobless => 1,
  18         dbh       => undef,
  19         dbi       => undef,
  20     }, $class;
  21
  22     # Grab the parameters we want to use
  23     foreach my $param ( keys %$self ) {
  24         next unless exists $args->{$param};
  25         $self->{$param} = $args->{$param};
  26     }
  27
  28     if ( $self->{dbh} ) {
  29         $self->{driver} = lc $self->{dbh}->{Driver}->{Name};
  30     }
  31     else {
  32         $self->open;
  33     }
  34
  35     # Foreign keys are turned off by default in SQLite3 (for now)
  36     #q.v.  http://search.cpan.org/~adamk/DBD-SQLite-1.27/lib/DBD/SQLite.pm#Foreign_Keys
  37     # for more info.
  38     if ( $self->driver eq 'sqlite' ) {
  39         $self->{dbh}->do( 'PRAGMA foreign_keys = ON' );
  40     }
  41
  42     return $self;
  43 }
  44
  45 sub open {
  46     my $self = shift;
  47
  48     return if $self->{dbh};
  49
  50     $self->{dbh} = DBI->connect(
  51         $self->{dbi}{dsn}, $self->{dbi}{username}, $self->{dbi}{password}, {
  52             AutoCommit => 0,
  53             PrintError => 0,
  54             RaiseError => 1,
  55             %{ $self->{dbi}{connect_args} || {} },
  56         },
  57     ) or die $DBI::error;
  58
  59     # Should we use the same method as done in new() if passed a $dbh?
  60     (undef, $self->{driver}) = map lc, DBI->parse_dsn( $self->{dbi}{dsn} );
  61
  62     return 1;
  63 }
  64
  65 sub close {
  66     my $self = shift;
  67     $self->{dbh}->disconnect if $self->{dbh};
  68     return 1;
  69 }
  70
  71 sub DESTROY {
  72     my $self = shift;
  73     $self->close if ref $self;
  74 }
  75
  76 # Is there a portable way of determining writability to a DBH?
  77 sub is_writable {
  78     my $self = shift;
  79     return 1;
  80 }
  81
  82 sub lock_exclusive {
  83     my $self = shift;
  84 }
  85
  86 sub lock_shared {
  87     my $self = shift;
  88 }
  89
  90 sub unlock {
  91     my $self = shift;
  92     $self->{dbh}->commit;
  93 }
  94
  95 sub read_from {
  96     my $self = shift;
  97     my ($table, $cond, @cols) = @_;
  98
  99     $cond = { id => $cond } unless ref $cond;
 100
 101     my @keys = keys %$cond;
 102     my $where = join ' AND ', map { "`$_` = ?" } @keys;
 103
 104     return $self->{dbh}->selectall_arrayref(
 105         "SELECT `@{[join '`,`', @cols ]}` FROM $table WHERE $where",
 106         { Slice => {} }, @{$cond}{@keys},
 107     );
 108 }
 109
 110 sub flush {}
 111
 112 sub write_to {
 113     my $self = shift;
 114     my ($table, $id, %args) = @_;
 115
 116     my @keys = keys %args;
 117     my $sql =
 118         "REPLACE INTO $table ( `id`, "
 119           . join( ',', map { "`$_`" } @keys )
 120       . ") VALUES ("
 121           . join( ',', ('?') x (@keys + 1) )
 122       . ")";
 123     $self->{dbh}->do( $sql, undef, $id, @args{@keys} );
 124
 125     return $self->{dbh}->last_insert_id("", "", "", "");
 126 }
 127
 128 sub delete_from {
 129     my $self = shift;
 130     my ($table, $cond) = @_;
 131
 132     $cond = { id => $cond } unless ref $cond;
 133
 134     my @keys = keys %$cond;
 135     my $where = join ' AND ', map { "`$_` = ?" } @keys;
 136
 137     $self->{dbh}->do(
 138         "DELETE FROM $table WHERE $where", undef, @{$cond}{@keys},
 139     );
 140 }
 141
 142 sub driver { $_[0]{driver} }
 143
 144 sub rand_function {
 145     my $self = shift;
 146     my $driver = $self->driver;
 147     if ( $driver eq 'sqlite' ) {
 148         return 'random()';
 149     }
 150     elsif ( $driver eq 'mysql' ) {
 151         return 'RAND()';
 152     }
 153
 154     die "rand_function undefined for $driver\n";
 155 }
 156
 157 1;
 158 __END__