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 | |
28 | $self->open unless $self->{dbh}; |
29 | |
30 | return $self; |
31 | } |
32 | |
33 | sub open { |
34 | my $self = shift; |
35 | |
36 | # TODO: Is this really what should happen? |
37 | return if $self->{dbh}; |
38 | |
39 | $self->{dbh} = DBI->connect( |
40 | $self->{dbi}{dsn}, $self->{dbi}{username}, $self->{dbi}{password}, { |
41 | AutoCommit => 0, |
42 | PrintError => 0, |
43 | RaiseError => 1, |
44 | %{ $self->{dbi}{connect_args} || {} }, |
45 | }, |
46 | ) or die $DBI::error; |
47 | |
48 | return 1; |
49 | } |
50 | |
51 | sub close { |
52 | my $self = shift; |
53 | $self->{dbh}->disconnect if $self->{dbh}; |
54 | return 1; |
55 | } |
56 | |
57 | sub DESTROY { |
58 | my $self = shift; |
59 | $self->close if ref $self; |
60 | } |
61 | |
62 | # Is there a portable way of determining writability to a DBH? |
2c70efe1 |
63 | sub is_writable { |
64 | my $self = shift; |
65 | return 1; |
66 | } |
67 | |
68 | sub lock_exclusive { |
69 | my $self = shift; |
70 | } |
71 | |
72 | sub lock_shared { |
73 | my $self = shift; |
74 | } |
75 | |
76 | sub unlock { |
77 | my $self = shift; |
78 | } |
79 | |
a4d36ff6 |
80 | sub read_from { |
81 | my $self = shift; |
82 | my ($table, $cond, @cols) = @_; |
83 | |
84 | $cond = { id => $cond } unless ref $cond; |
85 | |
86 | my @keys = keys %$cond; |
87 | my $where = join ' AND ', map { "`$_` = ?" } @keys; |
88 | |
89 | return $self->{dbh}->selectall_arrayref( |
90 | "SELECT `@{[join '`,`', @cols ]}` FROM $table WHERE $where", |
91 | { Slice => {} }, @{$cond}{@keys}, |
92 | ); |
93 | } |
94 | |
95 | sub flush {} |
96 | |
97 | sub write_to { |
98 | my $self = shift; |
99 | my ($table, $id, %args) = @_; |
100 | |
101 | if ( $id ) { |
102 | $self->{dbh}->do( |
103 | "DELETE FROM $table WHERE id = $id", |
104 | ); |
105 | } |
106 | |
107 | my @keys = keys %args; |
108 | my $sql = |
109 | "INSERT INTO $table ( `id`, " |
110 | . join( ',', map { "`$_`" } @keys ) |
111 | . ") VALUES (" |
112 | . join( ',', ('?') x (@keys + 1) ) |
113 | . ")"; |
114 | warn $sql. $/; |
115 | no warnings; |
116 | warn "@args{@keys}\n"; |
117 | $self->{dbh}->do( $sql, undef, $id, @args{@keys} ); |
118 | |
119 | return $self->{dbh}{mysql_insertid}; |
120 | } |
121 | |
122 | sub delete_from { |
123 | my $self = shift; |
124 | my ($table, $id) = @_; |
125 | |
126 | $self->{dbh}->do( |
127 | "DELETE FROM $table WHERE id = ?", undef, $id, |
128 | ); |
129 | } |
130 | |
2c70efe1 |
131 | 1; |
132 | __END__ |