Commit | Line | Data |
2c70efe1 |
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 | |
a4d36ff6 |
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 | |
bac1b5d5 |
28 | if ( $self->{dbh} ) { |
29 | $self->{driver} = lc $self->{dbh}->{Driver}->{Name}; |
30 | } |
31 | else { |
32 | $self->open; |
33 | } |
a4d36ff6 |
34 | |
35 | return $self; |
36 | } |
37 | |
38 | sub open { |
39 | my $self = shift; |
40 | |
a4d36ff6 |
41 | return if $self->{dbh}; |
42 | |
43 | $self->{dbh} = DBI->connect( |
44 | $self->{dbi}{dsn}, $self->{dbi}{username}, $self->{dbi}{password}, { |
45 | AutoCommit => 0, |
46 | PrintError => 0, |
47 | RaiseError => 1, |
48 | %{ $self->{dbi}{connect_args} || {} }, |
49 | }, |
50 | ) or die $DBI::error; |
51 | |
bac1b5d5 |
52 | # Should we use the same method as done in new() if passed a $dbh? |
53 | (undef, $self->{driver}) = map lc, DBI->parse_dsn( $self->{dbi}{dsn} ); |
54 | |
a4d36ff6 |
55 | return 1; |
56 | } |
57 | |
58 | sub close { |
59 | my $self = shift; |
60 | $self->{dbh}->disconnect if $self->{dbh}; |
61 | return 1; |
62 | } |
63 | |
64 | sub DESTROY { |
65 | my $self = shift; |
66 | $self->close if ref $self; |
67 | } |
68 | |
69 | # Is there a portable way of determining writability to a DBH? |
2c70efe1 |
70 | sub is_writable { |
71 | my $self = shift; |
72 | return 1; |
73 | } |
74 | |
75 | sub lock_exclusive { |
76 | my $self = shift; |
77 | } |
78 | |
79 | sub lock_shared { |
80 | my $self = shift; |
81 | } |
82 | |
83 | sub unlock { |
84 | my $self = shift; |
bac1b5d5 |
85 | $self->{dbh}->commit; |
2c70efe1 |
86 | } |
87 | |
a4d36ff6 |
88 | sub read_from { |
89 | my $self = shift; |
90 | my ($table, $cond, @cols) = @_; |
91 | |
92 | $cond = { id => $cond } unless ref $cond; |
93 | |
94 | my @keys = keys %$cond; |
95 | my $where = join ' AND ', map { "`$_` = ?" } @keys; |
96 | |
97 | return $self->{dbh}->selectall_arrayref( |
98 | "SELECT `@{[join '`,`', @cols ]}` FROM $table WHERE $where", |
99 | { Slice => {} }, @{$cond}{@keys}, |
100 | ); |
101 | } |
102 | |
103 | sub flush {} |
104 | |
105 | sub write_to { |
106 | my $self = shift; |
107 | my ($table, $id, %args) = @_; |
108 | |
a4d36ff6 |
109 | my @keys = keys %args; |
110 | my $sql = |
350896ee |
111 | "REPLACE INTO $table ( `id`, " |
a4d36ff6 |
112 | . join( ',', map { "`$_`" } @keys ) |
113 | . ") VALUES (" |
114 | . join( ',', ('?') x (@keys + 1) ) |
115 | . ")"; |
a4d36ff6 |
116 | $self->{dbh}->do( $sql, undef, $id, @args{@keys} ); |
117 | |
bac1b5d5 |
118 | return $self->{dbh}->last_insert_id("", "", "", ""); |
a4d36ff6 |
119 | } |
120 | |
121 | sub delete_from { |
122 | my $self = shift; |
350896ee |
123 | my ($table, $cond) = @_; |
124 | |
125 | $cond = { id => $cond } unless ref $cond; |
126 | |
127 | my @keys = keys %$cond; |
128 | my $where = join ' AND ', map { "`$_` = ?" } @keys; |
a4d36ff6 |
129 | |
130 | $self->{dbh}->do( |
350896ee |
131 | "DELETE FROM $table WHERE $where", undef, @{$cond}{@keys}, |
a4d36ff6 |
132 | ); |
133 | } |
134 | |
bac1b5d5 |
135 | sub driver { $_[0]{driver} } |
136 | |
137 | sub rand_function { |
138 | my $self = shift; |
139 | my $driver = $self->driver; |
140 | if ( $driver eq 'sqlite' ) { |
141 | return 'random()'; |
142 | } |
143 | elsif ( $driver eq 'mysql' ) { |
144 | return 'RAND()'; |
145 | } |
146 | |
147 | die "rand_function undefined for $driver\n"; |
148 | } |
149 | |
2c70efe1 |
150 | 1; |
151 | __END__ |