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