Cleanup in resultset, made storage prepare_cached for non-select statements
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Storage / DBI.pm
CommitLineData
8b445e33 1package DBIx::Class::Storage::DBI;
2
20a2c954 3use strict;
4use warnings;
8b445e33 5use DBI;
aeaf3ce2 6use SQL::Abstract::Limit;
28927b50 7use DBIx::Class::Storage::DBI::Cursor;
8b445e33 8
bd7efd39 9BEGIN {
10
11package DBIC::SQL::Abstract; # Temporary. Merge upstream.
12
13use base qw/SQL::Abstract::Limit/;
14
2a816814 15sub _table {
bd7efd39 16 my ($self, $from) = @_;
17 if (ref $from eq 'ARRAY') {
18 return $self->_recurse_from(@$from);
19 } elsif (ref $from eq 'HASH') {
20 return $self->_make_as($from);
21 } else {
22 return $from;
23 }
24}
25
26sub _recurse_from {
27 my ($self, $from, @join) = @_;
28 my @sqlf;
29 push(@sqlf, $self->_make_as($from));
30 foreach my $j (@join) {
31 my ($to, $on) = @$j;
73856587 32
33 # check whether a join type exists
34 my $join_clause = '';
35 if (ref($to) eq 'HASH' and exists($to->{-join_type})) {
36 $join_clause = ' '.uc($to->{-join_type}).' JOIN ';
37 } else {
38 $join_clause = ' JOIN ';
39 }
40 push(@sqlf, $join_clause);
41
bd7efd39 42 if (ref $to eq 'ARRAY') {
43 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
44 } else {
96cdbbab 45 push(@sqlf, $self->_make_as($to));
bd7efd39 46 }
47 push(@sqlf, ' ON ', $self->_join_condition($on));
48 }
49 return join('', @sqlf);
50}
51
52sub _make_as {
53 my ($self, $from) = @_;
2a816814 54 return join(' ', map { $self->_quote($_) }
55 reverse each %{$self->_skip_options($from)});
73856587 56}
57
58sub _skip_options {
59 my ($self, $hash) = @_;
60 my $clean_hash = {};
61 $clean_hash->{$_} = $hash->{$_}
62 for grep {!/^-/} keys %$hash;
63 return $clean_hash;
bd7efd39 64}
65
66sub _join_condition {
67 my ($self, $cond) = @_;
68 die "no chance" unless ref $cond eq 'HASH';
69 my %j;
2a816814 70 for (keys %$cond) { my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x; };
bd7efd39 71 return $self->_recurse_where(\%j);
72}
73
2a816814 74sub _quote {
75 my ($self, $label) = @_;
76 return '' unless defined $label;
77 return $self->SUPER::_quote($label);
78}
79
bd7efd39 80} # End of BEGIN block
81
8b445e33 82use base qw/DBIx::Class/;
83
438adc0e 84__PACKAGE__->load_components(qw/Exception AccessorGroup/);
8b445e33 85
223b8fe3 86__PACKAGE__->mk_group_accessors('simple' =>
48c69e7c 87 qw/connect_info _dbh _sql_maker debug cursor/);
8b445e33 88
89sub new {
223b8fe3 90 my $new = bless({}, ref $_[0] || $_[0]);
28927b50 91 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
92 $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG};
223b8fe3 93 return $new;
8b445e33 94}
95
8b445e33 96=head1 NAME
97
98DBIx::Class::Storage::DBI - DBI storage handler
99
100=head1 SYNOPSIS
101
102=head1 DESCRIPTION
103
104This class represents the connection to the database
105
106=head1 METHODS
107
108=over 4
109
110=cut
111
112sub dbh {
113 my ($self) = @_;
114 my $dbh;
115 unless (($dbh = $self->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
116 $self->_populate_dbh;
117 }
118 return $self->_dbh;
119}
120
48c69e7c 121sub sql_maker {
122 my ($self) = @_;
fdc1c3d0 123 unless ($self->_sql_maker) {
bd7efd39 124 $self->_sql_maker(new DBIC::SQL::Abstract( limit_dialect => $self->dbh ));
48c69e7c 125 }
126 return $self->_sql_maker;
127}
128
8b445e33 129sub _populate_dbh {
130 my ($self) = @_;
131 my @info = @{$self->connect_info || []};
132 $self->_dbh($self->_connect(@info));
133}
134
135sub _connect {
136 my ($self, @info) = @_;
137 return DBI->connect(@info);
138}
139
140=item commit
141
142 $class->commit;
143
144Issues a commit again the current dbh
145
146=cut
147
148sub commit { $_[0]->dbh->commit; }
149
150=item rollback
151
152 $class->rollback;
153
154Issues a rollback again the current dbh
155
156=cut
157
158sub rollback { $_[0]->dbh->rollback; }
159
223b8fe3 160sub _execute {
161 my ($self, $op, $extra_bind, $ident, @args) = @_;
162 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
944f30bf 163 unshift(@bind, @$extra_bind) if $extra_bind;
223b8fe3 164 warn "$sql: @bind" if $self->debug;
2f5911b2 165 my $sth = $self->sth($sql,$op);
438adc0e 166 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
167 my $rv = $sth->execute(@bind);
223b8fe3 168 return (wantarray ? ($rv, $sth, @bind) : $rv);
169}
170
8b445e33 171sub insert {
172 my ($self, $ident, $to_insert) = @_;
20a2c954 173 $self->throw( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" )
223b8fe3 174 unless ($self->_execute('insert' => [], $ident, $to_insert) > 0);
8b445e33 175 return $to_insert;
176}
177
178sub update {
223b8fe3 179 return shift->_execute('update' => [], @_);
8b445e33 180}
181
182sub delete {
223b8fe3 183 return shift->_execute('delete' => [], @_);
8b445e33 184}
185
de705b51 186sub _select {
8b445e33 187 my ($self, $ident, $select, $condition, $attrs) = @_;
223b8fe3 188 my $order = $attrs->{order_by};
189 if (ref $condition eq 'SCALAR') {
190 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
191 }
5c91499f 192 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
9229f20a 193 if ($attrs->{software_limit} ||
194 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
195 $attrs->{software_limit} = 1;
5c91499f 196 } else {
197 push @args, $attrs->{rows}, $attrs->{offset};
198 }
de705b51 199 return $self->_execute(@args);
200}
201
202sub select {
203 my $self = shift;
204 my ($ident, $select, $condition, $attrs) = @_;
205 my ($rv, $sth, @bind) = $self->_select(@_);
223b8fe3 206 return $self->cursor->new($sth, \@bind, $attrs);
8b445e33 207}
208
1a14aa3f 209sub select_single {
de705b51 210 my $self = shift;
211 my ($rv, $sth, @bind) = $self->_select(@_);
1a14aa3f 212 return $sth->fetchrow_array;
213}
214
8b445e33 215sub sth {
2f5911b2 216 my ($self, $sql, $op) = @_;
217 my $meth = (defined $op && $op ne 'select' ? 'prepare_cached' : 'prepare');
218 return $self->dbh->$meth($sql);
8b445e33 219}
220
2211;
222
223=back
224
225=head1 AUTHORS
226
daec44b8 227Matt S. Trout <mst@shadowcatsystems.co.uk>
8b445e33 228
9f19b1d6 229Andy Grundman <andy@hybridized.org>
230
8b445e33 231=head1 LICENSE
232
233You may distribute this code under the same terms as Perl itself.
234
235=cut
236