Merge 'trunk' into 'cdbicompat_integration'
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm
CommitLineData
8b445e33 1package DBIx::Class::Storage::DBI;
e673f011 2# -*- mode: cperl; cperl-indent-level: 2 -*-
8b445e33 3
a62cf8d4 4use base 'DBIx::Class::Storage';
5
eda28767 6use strict;
20a2c954 7use warnings;
8b445e33 8use DBI;
aeaf3ce2 9use SQL::Abstract::Limit;
28927b50 10use DBIx::Class::Storage::DBI::Cursor;
4c248161 11use DBIx::Class::Storage::Statistics;
664612fb 12use Scalar::Util qw/blessed weaken/;
046ad905 13
541df64a 14__PACKAGE__->mk_group_accessors('simple' =>
15 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
e4eb8ee1 16 _conn_pid _conn_tid disable_sth_caching on_connect_do
579ca3f7 17 on_disconnect_do transaction_depth unsafe _dbh_autocommit/
046ad905 18);
19
e4eb8ee1 20__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
21
95ba7ee4 22__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
23__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
24
bd7efd39 25BEGIN {
26
cb5f2eea 27package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
bd7efd39 28
29use base qw/SQL::Abstract::Limit/;
30
2cc3a7be 31# This prevents the caching of $dbh in S::A::L, I believe
32sub new {
33 my $self = shift->SUPER::new(@_);
34
35 # If limit_dialect is a ref (like a $dbh), go ahead and replace
36 # it with what it resolves to:
37 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
38 if ref $self->{limit_dialect};
39
40 $self;
41}
42
260129d8 43sub _RowNumberOver {
44 my ($self, $sql, $order, $rows, $offset ) = @_;
45
46 $offset += 1;
47 my $last = $rows + $offset;
48 my ( $order_by ) = $self->_order_by( $order );
49
50 $sql = <<"";
51SELECT * FROM
52(
53 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
54 $sql
55 $order_by
56 ) Q1
57) Q2
58WHERE ROW_NUM BETWEEN $offset AND $last
59
60 return $sql;
61}
62
63
2cc3a7be 64# While we're at it, this should make LIMIT queries more efficient,
65# without digging into things too deeply
758272ec 66use Scalar::Util 'blessed';
2cc3a7be 67sub _find_syntax {
68 my ($self, $syntax) = @_;
758272ec 69 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
260129d8 70 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
71 return 'RowNumberOver';
72 }
73
2cc3a7be 74 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
75}
76
54540863 77sub select {
78 my ($self, $table, $fields, $where, $order, @rest) = @_;
6346a152 79 $table = $self->_quote($table) unless ref($table);
eac29141 80 local $self->{rownum_hack_count} = 1
81 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
54540863 82 @rest = (-1) unless defined $rest[0];
0823196c 83 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
84 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
8839560b 85 local $self->{having_bind} = [];
bc0c9800 86 my ($sql, @ret) = $self->SUPER::select(
87 $table, $self->_recurse_fields($fields), $where, $order, @rest
88 );
95ba7ee4 89 $sql .=
90 $self->{for} ?
91 (
92 $self->{for} eq 'update' ? ' FOR UPDATE' :
93 $self->{for} eq 'shared' ? ' FOR SHARE' :
94 ''
95 ) :
96 ''
97 ;
8839560b 98 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
54540863 99}
100
6346a152 101sub insert {
102 my $self = shift;
103 my $table = shift;
104 $table = $self->_quote($table) unless ref($table);
105 $self->SUPER::insert($table, @_);
106}
107
108sub update {
109 my $self = shift;
110 my $table = shift;
111 $table = $self->_quote($table) unless ref($table);
112 $self->SUPER::update($table, @_);
113}
114
115sub delete {
116 my $self = shift;
117 my $table = shift;
118 $table = $self->_quote($table) unless ref($table);
119 $self->SUPER::delete($table, @_);
120}
121
54540863 122sub _emulate_limit {
123 my $self = shift;
124 if ($_[3] == -1) {
125 return $_[1].$self->_order_by($_[2]);
126 } else {
127 return $self->SUPER::_emulate_limit(@_);
128 }
129}
130
131sub _recurse_fields {
e8e971f2 132 my ($self, $fields, $params) = @_;
54540863 133 my $ref = ref $fields;
134 return $self->_quote($fields) unless $ref;
135 return $$fields if $ref eq 'SCALAR';
136
137 if ($ref eq 'ARRAY') {
1d78a406 138 return join(', ', map {
eac29141 139 $self->_recurse_fields($_)
1d78a406 140 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
141 ? ' AS col'.$self->{rownum_hack_count}++
142 : '')
e8e971f2 143 } @$fields);
54540863 144 } elsif ($ref eq 'HASH') {
145 foreach my $func (keys %$fields) {
146 return $self->_sqlcase($func)
147 .'( '.$self->_recurse_fields($fields->{$func}).' )';
148 }
149 }
150}
151
152sub _order_by {
153 my $self = shift;
154 my $ret = '';
8839560b 155 my @extra;
54540863 156 if (ref $_[0] eq 'HASH') {
157 if (defined $_[0]->{group_by}) {
158 $ret = $self->_sqlcase(' group by ')
1d78a406 159 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
54540863 160 }
8839560b 161 if (defined $_[0]->{having}) {
162 my $frag;
163 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
164 push(@{$self->{having_bind}}, @extra);
165 $ret .= $self->_sqlcase(' having ').$frag;
166 }
54540863 167 if (defined $_[0]->{order_by}) {
7ce5cbe7 168 $ret .= $self->_order_by($_[0]->{order_by});
54540863 169 }
d09c569a 170 } elsif (ref $_[0] eq 'SCALAR') {
e535069e 171 $ret = $self->_sqlcase(' order by ').${ $_[0] };
d09c569a 172 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
173 my @order = @{+shift};
174 $ret = $self->_sqlcase(' order by ')
175 .join(', ', map {
176 my $r = $self->_order_by($_, @_);
177 $r =~ s/^ ?ORDER BY //i;
178 $r;
179 } @order);
54540863 180 } else {
181 $ret = $self->SUPER::_order_by(@_);
182 }
183 return $ret;
184}
185
f48dd03f 186sub _order_directions {
187 my ($self, $order) = @_;
188 $order = $order->{order_by} if ref $order eq 'HASH';
189 return $self->SUPER::_order_directions($order);
190}
191
2a816814 192sub _table {
bd7efd39 193 my ($self, $from) = @_;
194 if (ref $from eq 'ARRAY') {
195 return $self->_recurse_from(@$from);
196 } elsif (ref $from eq 'HASH') {
197 return $self->_make_as($from);
198 } else {
6346a152 199 return $from; # would love to quote here but _table ends up getting called
200 # twice during an ->select without a limit clause due to
201 # the way S::A::Limit->select works. should maybe consider
202 # bypassing this and doing S::A::select($self, ...) in
203 # our select method above. meantime, quoting shims have
204 # been added to select/insert/update/delete here
bd7efd39 205 }
206}
207
208sub _recurse_from {
209 my ($self, $from, @join) = @_;
210 my @sqlf;
211 push(@sqlf, $self->_make_as($from));
212 foreach my $j (@join) {
213 my ($to, $on) = @$j;
73856587 214
54540863 215 # check whether a join type exists
216 my $join_clause = '';
ca7b9fdf 217 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
218 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
219 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
54540863 220 } else {
221 $join_clause = ' JOIN ';
222 }
73856587 223 push(@sqlf, $join_clause);
224
bd7efd39 225 if (ref $to eq 'ARRAY') {
226 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
227 } else {
96cdbbab 228 push(@sqlf, $self->_make_as($to));
bd7efd39 229 }
230 push(@sqlf, ' ON ', $self->_join_condition($on));
231 }
232 return join('', @sqlf);
233}
234
235sub _make_as {
236 my ($self, $from) = @_;
54540863 237 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
bc0c9800 238 reverse each %{$self->_skip_options($from)});
73856587 239}
240
241sub _skip_options {
54540863 242 my ($self, $hash) = @_;
243 my $clean_hash = {};
244 $clean_hash->{$_} = $hash->{$_}
245 for grep {!/^-/} keys %$hash;
246 return $clean_hash;
bd7efd39 247}
248
249sub _join_condition {
250 my ($self, $cond) = @_;
5efe4c79 251 if (ref $cond eq 'HASH') {
252 my %j;
bc0c9800 253 for (keys %$cond) {
635b9634 254 my $v = $cond->{$_};
255 if (ref $v) {
256 # XXX no throw_exception() in this package and croak() fails with strange results
257 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
258 if ref($v) ne 'SCALAR';
259 $j{$_} = $v;
260 }
261 else {
262 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
263 }
bc0c9800 264 };
635b9634 265 return scalar($self->_recurse_where(\%j));
5efe4c79 266 } elsif (ref $cond eq 'ARRAY') {
267 return join(' OR ', map { $self->_join_condition($_) } @$cond);
268 } else {
269 die "Can't handle this yet!";
270 }
bd7efd39 271}
272
2a816814 273sub _quote {
274 my ($self, $label) = @_;
275 return '' unless defined $label;
3b24f6ea 276 return "*" if $label eq '*';
41728a6e 277 return $label unless $self->{quote_char};
3b24f6ea 278 if(ref $self->{quote_char} eq "ARRAY"){
279 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
280 if !defined $self->{name_sep};
281 my $sep = $self->{name_sep};
282 return join($self->{name_sep},
283 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
284 split(/\Q$sep\E/,$label));
285 }
2a816814 286 return $self->SUPER::_quote($label);
287}
288
7be93b07 289sub limit_dialect {
290 my $self = shift;
291 $self->{limit_dialect} = shift if @_;
292 return $self->{limit_dialect};
293}
294
2437a1e3 295sub quote_char {
296 my $self = shift;
297 $self->{quote_char} = shift if @_;
298 return $self->{quote_char};
299}
300
301sub name_sep {
302 my $self = shift;
303 $self->{name_sep} = shift if @_;
304 return $self->{name_sep};
305}
306
bd7efd39 307} # End of BEGIN block
308
b327f988 309=head1 NAME
310
311DBIx::Class::Storage::DBI - DBI storage handler
312
313=head1 SYNOPSIS
314
315=head1 DESCRIPTION
316
046ad905 317This class represents the connection to an RDBMS via L<DBI>. See
318L<DBIx::Class::Storage> for general information. This pod only
319documents DBI-specific methods and behaviors.
b327f988 320
321=head1 METHODS
322
9b83fccd 323=cut
324
8b445e33 325sub new {
046ad905 326 my $new = shift->next::method(@_);
82cc0386 327
d79f59b9 328 $new->transaction_depth(0);
2cc3a7be 329 $new->_sql_maker_opts({});
1b994857 330 $new->{_in_dbh_do} = 0;
dbaee748 331 $new->{_dbh_gen} = 0;
82cc0386 332
046ad905 333 $new;
1c339d71 334}
335
1b45b01e 336=head2 connect_info
337
bb4f246d 338The arguments of C<connect_info> are always a single array reference.
1b45b01e 339
bb4f246d 340This is normally accessed via L<DBIx::Class::Schema/connection>, which
341encapsulates its argument list in an arrayref before calling
342C<connect_info> here.
1b45b01e 343
bb4f246d 344The arrayref can either contain the same set of arguments one would
345normally pass to L<DBI/connect>, or a lone code reference which returns
77d76d0f 346a connected database handle. Please note that the L<DBI> docs
347recommend that you always explicitly set C<AutoCommit> to either
348C<0> or C<1>. L<DBIx::Class> further recommends that it be set
349to C<1>, and that you perform transactions via our L</txn_do>
2bc2ddc7 350method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
351set it to zero. This is the default for most DBDs. See below for more
352details.
d7c4c15c 353
2cc3a7be 354In either case, if the final argument in your connect_info happens
355to be a hashref, C<connect_info> will look there for several
356connection-specific options:
357
358=over 4
359
360=item on_connect_do
361
6d2e7a96 362Specifies things to do immediately after connecting or re-connecting to
363the database. Its value may contain:
364
365=over
366
367=item an array reference
368
369This contains SQL statements to execute in order. Each element contains
370a string or a code reference that returns a string.
371
372=item a code reference
373
374This contains some code to execute. Unlike code references within an
375array reference, its return value is ignored.
376
377=back
579ca3f7 378
379=item on_disconnect_do
380
1dafdb2a 381Takes arguments in the same form as L<on_connect_do> and executes them
6d2e7a96 382immediately before disconnecting from the database.
579ca3f7 383
384Note, this only runs if you explicitly call L<disconnect> on the
385storage object.
2cc3a7be 386
b33697ef 387=item disable_sth_caching
388
389If set to a true value, this option will disable the caching of
390statement handles via L<DBI/prepare_cached>.
391
2cc3a7be 392=item limit_dialect
393
394Sets the limit dialect. This is useful for JDBC-bridge among others
395where the remote SQL-dialect cannot be determined by the name of the
396driver alone.
397
398=item quote_char
d7c4c15c 399
2cc3a7be 400Specifies what characters to use to quote table and column names. If
401you use this you will want to specify L<name_sep> as well.
402
403quote_char expects either a single character, in which case is it is placed
404on either side of the table/column, or an arrayref of length 2 in which case the
405table/column name is placed between the elements.
406
407For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
408use C<quote_char =E<gt> [qw/[ ]/]>.
409
410=item name_sep
411
412This only needs to be used in conjunction with L<quote_char>, and is used to
413specify the charecter that seperates elements (schemas, tables, columns) from
414each other. In most cases this is simply a C<.>.
415
61646ebd 416=item unsafe
417
418This Storage driver normally installs its own C<HandleError>, sets
2ab60eb9 419C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
420all database handles, including those supplied by a coderef. It does this
421so that it can have consistent and useful error behavior.
61646ebd 422
423If you set this option to a true value, Storage will not do its usual
2ab60eb9 424modifications to the database handle's attributes, and instead relies on
425the settings in your connect_info DBI options (or the values you set in
426your connection coderef, in the case that you are connecting via coderef).
61646ebd 427
428Note that your custom settings can cause Storage to malfunction,
429especially if you set a C<HandleError> handler that suppresses exceptions
430and/or disable C<RaiseError>.
431
2cc3a7be 432=back
433
434These options can be mixed in with your other L<DBI> connection attributes,
435or placed in a seperate hashref after all other normal L<DBI> connection
436arguments.
437
438Every time C<connect_info> is invoked, any previous settings for
439these options will be cleared before setting the new ones, regardless of
440whether any options are specified in the new C<connect_info>.
441
77d76d0f 442Another Important Note:
443
444DBIC can do some wonderful magic with handling exceptions,
445disconnections, and transactions when you use C<AutoCommit =&gt; 1>
446combined with C<txn_do> for transaction support.
447
448If you set C<AutoCommit =&gt; 0> in your connect info, then you are always
449in an assumed transaction between commits, and you're telling us you'd
450like to manage that manually. A lot of DBIC's magic protections
451go away. We can't protect you from exceptions due to database
452disconnects because we don't know anything about how to restart your
453transactions. You're on your own for handling all sorts of exceptional
454cases if you choose the C<AutoCommit =&gt 0> path, just as you would
455be with raw DBI.
456
2cc3a7be 457Examples:
458
459 # Simple SQLite connection
bb4f246d 460 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
6789ebe3 461
2cc3a7be 462 # Connect via subref
bb4f246d 463 ->connect_info([ sub { DBI->connect(...) } ]);
6789ebe3 464
2cc3a7be 465 # A bit more complicated
bb4f246d 466 ->connect_info(
467 [
468 'dbi:Pg:dbname=foo',
469 'postgres',
470 'my_pg_password',
77d76d0f 471 { AutoCommit => 1 },
2cc3a7be 472 { quote_char => q{"}, name_sep => q{.} },
473 ]
474 );
475
476 # Equivalent to the previous example
477 ->connect_info(
478 [
479 'dbi:Pg:dbname=foo',
480 'postgres',
481 'my_pg_password',
77d76d0f 482 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
bb4f246d 483 ]
484 );
6789ebe3 485
2cc3a7be 486 # Subref + DBIC-specific connection options
bb4f246d 487 ->connect_info(
488 [
489 sub { DBI->connect(...) },
2cc3a7be 490 {
491 quote_char => q{`},
492 name_sep => q{@},
493 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
b33697ef 494 disable_sth_caching => 1,
2cc3a7be 495 },
bb4f246d 496 ]
497 );
6789ebe3 498
004d31fb 499=cut
500
046ad905 501sub connect_info {
502 my ($self, $info_arg) = @_;
4c248161 503
046ad905 504 return $self->_connect_info if !$info_arg;
4c248161 505
046ad905 506 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
507 # the new set of options
508 $self->_sql_maker(undef);
509 $self->_sql_maker_opts({});
fdad5fab 510 $self->_connect_info([@$info_arg]); # copy for _connect_info
486ad69b 511
fdad5fab 512 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
8df3d107 513
541df64a 514 my $last_info = $dbi_info->[-1];
046ad905 515 if(ref $last_info eq 'HASH') {
9a0891be 516 $last_info = { %$last_info }; # so delete is non-destructive
5322ea52 517 my @storage_option = qw(
518 on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
519 );
579ca3f7 520 for my $storage_opt (@storage_option) {
b33697ef 521 if(my $value = delete $last_info->{$storage_opt}) {
522 $self->$storage_opt($value);
523 }
046ad905 524 }
525 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
526 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
527 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
528 }
529 }
9a0891be 530 # re-insert modified hashref
531 $dbi_info->[-1] = $last_info;
486ad69b 532
046ad905 533 # Get rid of any trailing empty hashref
541df64a 534 pop(@$dbi_info) if !keys %$last_info;
046ad905 535 }
fdad5fab 536 $self->_dbi_connect_info($dbi_info);
d7c4c15c 537
fdad5fab 538 $self->_connect_info;
046ad905 539}
004d31fb 540
046ad905 541=head2 on_connect_do
4c248161 542
046ad905 543This method is deprecated in favor of setting via L</connect_info>.
486ad69b 544
f11383c2 545=head2 dbh_do
546
046ad905 547Arguments: $subref, @extra_coderef_args?
548
d4f16b21 549Execute the given subref using the new exception-based connection management.
046ad905 550
d4f16b21 551The first two arguments will be the storage object that C<dbh_do> was called
552on and a database handle to use. Any additional arguments will be passed
553verbatim to the called subref as arguments 2 and onwards.
554
555Using this (instead of $self->_dbh or $self->dbh) ensures correct
556exception handling and reconnection (or failover in future subclasses).
557
558Your subref should have no side-effects outside of the database, as
559there is the potential for your subref to be partially double-executed
560if the database connection was stale/dysfunctional.
046ad905 561
56769f7c 562Example:
f11383c2 563
56769f7c 564 my @stuff = $schema->storage->dbh_do(
565 sub {
d4f16b21 566 my ($storage, $dbh, @cols) = @_;
567 my $cols = join(q{, }, @cols);
568 $dbh->selectrow_array("SELECT $cols FROM foo");
046ad905 569 },
570 @column_list
56769f7c 571 );
f11383c2 572
573=cut
574
575sub dbh_do {
046ad905 576 my $self = shift;
aa27edf7 577 my $coderef = shift;
578
aa27edf7 579 ref $coderef eq 'CODE' or $self->throw_exception
580 ('$coderef must be a CODE reference');
f11383c2 581
cb19f4dd 582 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
583 || $self->{transaction_depth};
584
1b994857 585 local $self->{_in_dbh_do} = 1;
586
f11383c2 587 my @result;
588 my $want_array = wantarray;
589
590 eval {
56769f7c 591 $self->_verify_pid if $self->_dbh;
f11383c2 592 $self->_populate_dbh if !$self->_dbh;
f11383c2 593 if($want_array) {
d4f16b21 594 @result = $coderef->($self, $self->_dbh, @_);
f11383c2 595 }
56769f7c 596 elsif(defined $want_array) {
d4f16b21 597 $result[0] = $coderef->($self, $self->_dbh, @_);
f11383c2 598 }
56769f7c 599 else {
d4f16b21 600 $coderef->($self, $self->_dbh, @_);
56769f7c 601 }
f11383c2 602 };
56769f7c 603
aa27edf7 604 my $exception = $@;
605 if(!$exception) { return $want_array ? @result : $result[0] }
606
607 $self->throw_exception($exception) if $self->connected;
608
609 # We were not connected - reconnect and retry, but let any
610 # exception fall right through this time
611 $self->_populate_dbh;
d4f16b21 612 $coderef->($self, $self->_dbh, @_);
aa27edf7 613}
614
615# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
616# It also informs dbh_do to bypass itself while under the direction of txn_do,
1b994857 617# via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
aa27edf7 618sub txn_do {
619 my $self = shift;
620 my $coderef = shift;
621
622 ref $coderef eq 'CODE' or $self->throw_exception
623 ('$coderef must be a CODE reference');
624
57c18b65 625 return $coderef->(@_) if $self->{transaction_depth};
626
1b994857 627 local $self->{_in_dbh_do} = 1;
f11383c2 628
aa27edf7 629 my @result;
630 my $want_array = wantarray;
631
d4f16b21 632 my $tried = 0;
633 while(1) {
634 eval {
635 $self->_verify_pid if $self->_dbh;
636 $self->_populate_dbh if !$self->_dbh;
aa27edf7 637
d4f16b21 638 $self->txn_begin;
639 if($want_array) {
640 @result = $coderef->(@_);
641 }
642 elsif(defined $want_array) {
643 $result[0] = $coderef->(@_);
644 }
645 else {
646 $coderef->(@_);
647 }
648 $self->txn_commit;
649 };
aa27edf7 650
d4f16b21 651 my $exception = $@;
652 if(!$exception) { return $want_array ? @result : $result[0] }
653
654 if($tried++ > 0 || $self->connected) {
655 eval { $self->txn_rollback };
656 my $rollback_exception = $@;
657 if($rollback_exception) {
658 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
659 $self->throw_exception($exception) # propagate nested rollback
660 if $rollback_exception =~ /$exception_class/;
661
662 $self->throw_exception(
663 "Transaction aborted: ${exception}. "
664 . "Rollback failed: ${rollback_exception}"
665 );
666 }
667 $self->throw_exception($exception)
aa27edf7 668 }
56769f7c 669
d4f16b21 670 # We were not connected, and was first try - reconnect and retry
671 # via the while loop
672 $self->_populate_dbh;
673 }
f11383c2 674}
675
9b83fccd 676=head2 disconnect
677
046ad905 678Our C<disconnect> method also performs a rollback first if the
9b83fccd 679database is not in C<AutoCommit> mode.
680
681=cut
682
412db1f4 683sub disconnect {
684 my ($self) = @_;
685
92925617 686 if( $self->connected ) {
6d2e7a96 687 my $connection_do = $self->on_disconnect_do;
688 $self->_do_connection_actions($connection_do) if ref($connection_do);
689
57c18b65 690 $self->_dbh->rollback unless $self->_dbh_autocommit;
92925617 691 $self->_dbh->disconnect;
692 $self->_dbh(undef);
dbaee748 693 $self->{_dbh_gen}++;
92925617 694 }
412db1f4 695}
696
f11383c2 697sub connected {
698 my ($self) = @_;
412db1f4 699
1346e22d 700 if(my $dbh = $self->_dbh) {
701 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
dbaee748 702 $self->_dbh(undef);
703 $self->{_dbh_gen}++;
704 return;
1346e22d 705 }
56769f7c 706 else {
707 $self->_verify_pid;
649bfb8c 708 return 0 if !$self->_dbh;
56769f7c 709 }
1346e22d 710 return ($dbh->FETCH('Active') && $dbh->ping);
711 }
712
713 return 0;
412db1f4 714}
715
f11383c2 716# handle pid changes correctly
56769f7c 717# NOTE: assumes $self->_dbh is a valid $dbh
f11383c2 718sub _verify_pid {
719 my ($self) = @_;
720
6ae3f9b9 721 return if defined $self->_conn_pid && $self->_conn_pid == $$;
f11383c2 722
f11383c2 723 $self->_dbh->{InactiveDestroy} = 1;
d3abf3fe 724 $self->_dbh(undef);
dbaee748 725 $self->{_dbh_gen}++;
f11383c2 726
727 return;
728}
729
412db1f4 730sub ensure_connected {
731 my ($self) = @_;
732
733 unless ($self->connected) {
8b445e33 734 $self->_populate_dbh;
735 }
412db1f4 736}
737
c235bbae 738=head2 dbh
739
740Returns the dbh - a data base handle of class L<DBI>.
741
742=cut
743
412db1f4 744sub dbh {
745 my ($self) = @_;
746
747 $self->ensure_connected;
8b445e33 748 return $self->_dbh;
749}
750
f1f56aad 751sub _sql_maker_args {
752 my ($self) = @_;
753
6e399b4f 754 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
f1f56aad 755}
756
48c69e7c 757sub sql_maker {
758 my ($self) = @_;
fdc1c3d0 759 unless ($self->_sql_maker) {
95ba7ee4 760 my $sql_maker_class = $self->sql_maker_class;
761 $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
48c69e7c 762 }
763 return $self->_sql_maker;
764}
765
8b445e33 766sub _populate_dbh {
767 my ($self) = @_;
7e47ea83 768 my @info = @{$self->_dbi_connect_info || []};
8b445e33 769 $self->_dbh($self->_connect(@info));
2fd24e78 770
77d76d0f 771 # Always set the transaction depth on connect, since
772 # there is no transaction in progress by definition
57c18b65 773 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
77d76d0f 774
2fd24e78 775 if(ref $self eq 'DBIx::Class::Storage::DBI') {
776 my $driver = $self->_dbh->{Driver}->{Name};
efe6365b 777 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
2fd24e78 778 bless $self, "DBIx::Class::Storage::DBI::${driver}";
779 $self->_rebless() if $self->can('_rebless');
780 }
843f8ecd 781 }
2fd24e78 782
6d2e7a96 783 my $connection_do = $self->on_connect_do;
784 $self->_do_connection_actions($connection_do) if ref($connection_do);
5ef3e508 785
1346e22d 786 $self->_conn_pid($$);
787 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
8b445e33 788}
789
6d2e7a96 790sub _do_connection_actions {
791 my $self = shift;
792 my $connection_do = shift;
793
794 if (ref $connection_do eq 'ARRAY') {
795 $self->_do_query($_) foreach @$connection_do;
796 }
797 elsif (ref $connection_do eq 'CODE') {
798 $connection_do->();
799 }
800
801 return $self;
802}
803
579ca3f7 804sub _do_query {
805 my ($self, $action) = @_;
806
6d2e7a96 807 if (ref $action eq 'CODE') {
1dafdb2a 808 $action = $action->($self);
809 $self->_do_query($_) foreach @$action;
579ca3f7 810 }
811 else {
1bd1640b 812 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
813 $self->_query_start(@to_run);
814 $self->_dbh->do(@to_run);
815 $self->_query_end(@to_run);
579ca3f7 816 }
817
818 return $self;
819}
820
8b445e33 821sub _connect {
822 my ($self, @info) = @_;
5ef3e508 823
9d31f7dc 824 $self->throw_exception("You failed to provide any connection info")
61646ebd 825 if !@info;
9d31f7dc 826
90ec6cad 827 my ($old_connect_via, $dbh);
828
5ef3e508 829 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
61646ebd 830 $old_connect_via = $DBI::connect_via;
831 $DBI::connect_via = 'connect';
5ef3e508 832 }
833
75db246c 834 eval {
f5de3933 835 if(ref $info[0] eq 'CODE') {
836 $dbh = &{$info[0]}
837 }
838 else {
839 $dbh = DBI->connect(@info);
61646ebd 840 }
841
e7827df0 842 if($dbh && !$self->unsafe) {
664612fb 843 my $weak_self = $self;
844 weaken($weak_self);
61646ebd 845 $dbh->{HandleError} = sub {
664612fb 846 $weak_self->throw_exception("DBI Exception: $_[0]")
61646ebd 847 };
2ab60eb9 848 $dbh->{ShowErrorStatement} = 1;
61646ebd 849 $dbh->{RaiseError} = 1;
850 $dbh->{PrintError} = 0;
f5de3933 851 }
75db246c 852 };
90ec6cad 853
854 $DBI::connect_via = $old_connect_via if $old_connect_via;
855
d92a4015 856 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
857 if !$dbh || $@;
90ec6cad 858
57c18b65 859 $self->_dbh_autocommit($dbh->{AutoCommit});
860
e571e823 861 $dbh;
8b445e33 862}
863
d32d82f9 864
8091aa91 865sub txn_begin {
d79f59b9 866 my $self = shift;
291bf95f 867 $self->ensure_connected();
57c18b65 868 if($self->{transaction_depth} == 0) {
77d76d0f 869 $self->debugobj->txn_begin()
870 if $self->debug;
871 # this isn't ->_dbh-> because
872 # we should reconnect on begin_work
873 # for AutoCommit users
874 $self->dbh->begin_work;
986e4fca 875 }
57c18b65 876 $self->{transaction_depth}++;
8091aa91 877}
8b445e33 878
8091aa91 879sub txn_commit {
d79f59b9 880 my $self = shift;
77d76d0f 881 if ($self->{transaction_depth} == 1) {
882 my $dbh = $self->_dbh;
883 $self->debugobj->txn_commit()
884 if ($self->debug);
885 $dbh->commit;
886 $self->{transaction_depth} = 0
57c18b65 887 if $self->_dbh_autocommit;
77d76d0f 888 }
889 elsif($self->{transaction_depth} > 1) {
890 $self->{transaction_depth}--
891 }
d32d82f9 892}
893
77d76d0f 894sub txn_rollback {
895 my $self = shift;
896 my $dbh = $self->_dbh;
77d76d0f 897 eval {
77d76d0f 898 if ($self->{transaction_depth} == 1) {
d32d82f9 899 $self->debugobj->txn_rollback()
900 if ($self->debug);
77d76d0f 901 $self->{transaction_depth} = 0
57c18b65 902 if $self->_dbh_autocommit;
903 $dbh->rollback;
d32d82f9 904 }
77d76d0f 905 elsif($self->{transaction_depth} > 1) {
906 $self->{transaction_depth}--;
986e4fca 907 }
f11383c2 908 else {
d32d82f9 909 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
986e4fca 910 }
77d76d0f 911 };
a62cf8d4 912 if ($@) {
913 my $error = $@;
914 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
915 $error =~ /$exception_class/ and $self->throw_exception($error);
77d76d0f 916 # ensure that a failed rollback resets the transaction depth
57c18b65 917 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
77d76d0f 918 $self->throw_exception($error);
8091aa91 919 }
920}
8b445e33 921
b7151206 922# This used to be the top-half of _execute. It was split out to make it
923# easier to override in NoBindVars without duping the rest. It takes up
924# all of _execute's args, and emits $sql, @bind.
925sub _prep_for_execute {
d944c5ae 926 my ($self, $op, $extra_bind, $ident, $args) = @_;
b7151206 927
d944c5ae 928 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
db4b5f11 929 unshift(@bind,
930 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
931 if $extra_bind;
b7151206 932
d944c5ae 933 return ($sql, \@bind);
b7151206 934}
935
e5d9ee92 936sub _fix_bind_params {
937 my ($self, @bind) = @_;
938
939 ### Turn @bind from something like this:
940 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
941 ### to this:
942 ### ( "'1'", "'1'", "'3'" )
943 return
944 map {
945 if ( defined( $_ && $_->[1] ) ) {
946 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
947 }
948 else { q{'NULL'}; }
949 } @bind;
950}
951
952sub _query_start {
953 my ( $self, $sql, @bind ) = @_;
954
955 if ( $self->debug ) {
956 @bind = $self->_fix_bind_params(@bind);
957 $self->debugobj->query_start( $sql, @bind );
958 }
959}
960
961sub _query_end {
962 my ( $self, $sql, @bind ) = @_;
963
964 if ( $self->debug ) {
965 @bind = $self->_fix_bind_params(@bind);
966 $self->debugobj->query_end( $sql, @bind );
967 }
968}
969
baa31d2f 970sub _dbh_execute {
971 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
7af8b477 972
eda28767 973 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
b7ce6568 974 $ident = $ident->from();
975 }
d944c5ae 976
977 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
d92a4015 978
e5d9ee92 979 $self->_query_start( $sql, @$bind );
95dad7e2 980
61646ebd 981 my $sth = $self->sth($sql,$op);
6e399b4f 982
61646ebd 983 my $placeholder_index = 1;
6e399b4f 984
61646ebd 985 foreach my $bound (@$bind) {
986 my $attributes = {};
987 my($column_name, @data) = @$bound;
6e399b4f 988
61646ebd 989 if ($bind_attributes) {
990 $attributes = $bind_attributes->{$column_name}
991 if defined $bind_attributes->{$column_name};
992 }
6e399b4f 993
61646ebd 994 foreach my $data (@data) {
995 $data = ref $data ? ''.$data : $data; # stringify args
0b5dee17 996
61646ebd 997 $sth->bind_param($placeholder_index, $data, $attributes);
998 $placeholder_index++;
95dad7e2 999 }
61646ebd 1000 }
d92a4015 1001
61646ebd 1002 # Can this fail without throwing an exception anyways???
1003 my $rv = $sth->execute();
1004 $self->throw_exception($sth->errstr) if !$rv;
d92a4015 1005
e5d9ee92 1006 $self->_query_end( $sql, @$bind );
baa31d2f 1007
d944c5ae 1008 return (wantarray ? ($rv, $sth, @$bind) : $rv);
223b8fe3 1009}
1010
baa31d2f 1011sub _execute {
1012 my $self = shift;
1013 $self->dbh_do($self->can('_dbh_execute'), @_)
1014}
1015
8b445e33 1016sub insert {
7af8b477 1017 my ($self, $source, $to_insert) = @_;
1018
1019 my $ident = $source->from;
8b646589 1020 my $bind_attributes = $self->source_bind_attributes($source);
1021
61646ebd 1022 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
8e08ecc4 1023
8b445e33 1024 return $to_insert;
1025}
1026
744076d8 1027## Still not quite perfect, and EXPERIMENTAL
1028## Currently it is assumed that all values passed will be "normal", i.e. not
1029## scalar refs, or at least, all the same type as the first set, the statement is
1030## only prepped once.
54e0bd06 1031sub insert_bulk {
9fdf90df 1032 my ($self, $source, $cols, $data) = @_;
744076d8 1033 my %colvalues;
9fdf90df 1034 my $table = $source->from;
744076d8 1035 @colvalues{@$cols} = (0..$#$cols);
1036 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
7af8b477 1037
e5d9ee92 1038 $self->_query_start( $sql, @bind );
894328b8 1039 my $sth = $self->sth($sql);
54e0bd06 1040
54e0bd06 1041# @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1042
744076d8 1043 ## This must be an arrayref, else nothing works!
9fdf90df 1044
744076d8 1045 my $tuple_status = [];
9fdf90df 1046
1047 ##use Data::Dumper;
1048 ##print STDERR Dumper( $data, $sql, [@bind] );
eda28767 1049
61646ebd 1050 my $time = time();
8b646589 1051
61646ebd 1052 ## Get the bind_attributes, if any exist
1053 my $bind_attributes = $self->source_bind_attributes($source);
9fdf90df 1054
61646ebd 1055 ## Bind the values and execute
1056 my $placeholder_index = 1;
9fdf90df 1057
61646ebd 1058 foreach my $bound (@bind) {
9fdf90df 1059
61646ebd 1060 my $attributes = {};
1061 my ($column_name, $data_index) = @$bound;
eda28767 1062
61646ebd 1063 if( $bind_attributes ) {
1064 $attributes = $bind_attributes->{$column_name}
1065 if defined $bind_attributes->{$column_name};
1066 }
9fdf90df 1067
61646ebd 1068 my @data = map { $_->[$data_index] } @$data;
9fdf90df 1069
61646ebd 1070 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1071 $placeholder_index++;
54e0bd06 1072 }
61646ebd 1073 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1074 $self->throw_exception($sth->errstr) if !$rv;
1075
e5d9ee92 1076 $self->_query_end( $sql, @bind );
54e0bd06 1077 return (wantarray ? ($rv, $sth, @bind) : $rv);
1078}
1079
8b445e33 1080sub update {
7af8b477 1081 my $self = shift @_;
1082 my $source = shift @_;
8b646589 1083 my $bind_attributes = $self->source_bind_attributes($source);
8b646589 1084
b7ce6568 1085 return $self->_execute('update' => [], $source, $bind_attributes, @_);
8b445e33 1086}
1087
7af8b477 1088
8b445e33 1089sub delete {
7af8b477 1090 my $self = shift @_;
1091 my $source = shift @_;
1092
1093 my $bind_attrs = {}; ## If ever it's needed...
7af8b477 1094
b7ce6568 1095 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
8b445e33 1096}
1097
de705b51 1098sub _select {
8b445e33 1099 my ($self, $ident, $select, $condition, $attrs) = @_;
223b8fe3 1100 my $order = $attrs->{order_by};
95ba7ee4 1101
223b8fe3 1102 if (ref $condition eq 'SCALAR') {
1103 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1104 }
95ba7ee4 1105
1106 my $for = delete $attrs->{for};
1107 my $sql_maker = $self->sql_maker;
1108 local $sql_maker->{for} = $for;
1109
8839560b 1110 if (exists $attrs->{group_by} || $attrs->{having}) {
bc0c9800 1111 $order = {
1112 group_by => $attrs->{group_by},
1113 having => $attrs->{having},
1114 ($order ? (order_by => $order) : ())
1115 };
54540863 1116 }
7af8b477 1117 my $bind_attrs = {}; ## Future support
1118 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
9229f20a 1119 if ($attrs->{software_limit} ||
1120 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1121 $attrs->{software_limit} = 1;
5c91499f 1122 } else {
0823196c 1123 $self->throw_exception("rows attribute must be positive if present")
1124 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
e60dc79f 1125
1126 # MySQL actually recommends this approach. I cringe.
1127 $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
5c91499f 1128 push @args, $attrs->{rows}, $attrs->{offset};
1129 }
95ba7ee4 1130
de705b51 1131 return $self->_execute(@args);
1132}
1133
8b646589 1134sub source_bind_attributes {
1135 my ($self, $source) = @_;
1136
1137 my $bind_attributes;
1138 foreach my $column ($source->columns) {
1139
1140 my $data_type = $source->column_info($column)->{data_type} || '';
1141 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
eda28767 1142 if $data_type;
8b646589 1143 }
1144
1145 return $bind_attributes;
1146}
1147
9b83fccd 1148=head2 select
1149
d3b0e369 1150=over 4
1151
1152=item Arguments: $ident, $select, $condition, $attrs
1153
1154=back
1155
9b83fccd 1156Handle a SQL select statement.
1157
1158=cut
1159
de705b51 1160sub select {
1161 my $self = shift;
1162 my ($ident, $select, $condition, $attrs) = @_;
e4eb8ee1 1163 return $self->cursor_class->new($self, \@_, $attrs);
8b445e33 1164}
1165
1a14aa3f 1166sub select_single {
de705b51 1167 my $self = shift;
1168 my ($rv, $sth, @bind) = $self->_select(@_);
6157db4f 1169 my @row = $sth->fetchrow_array;
a3eaff0e 1170 # Need to call finish() to work round broken DBDs
6157db4f 1171 $sth->finish();
1172 return @row;
1a14aa3f 1173}
1174
9b83fccd 1175=head2 sth
1176
d3b0e369 1177=over 4
1178
1179=item Arguments: $sql
1180
1181=back
1182
9b83fccd 1183Returns a L<DBI> sth (statement handle) for the supplied SQL.
1184
1185=cut
1186
d4f16b21 1187sub _dbh_sth {
1188 my ($self, $dbh, $sql) = @_;
b33697ef 1189
d32d82f9 1190 # 3 is the if_active parameter which avoids active sth re-use
b33697ef 1191 my $sth = $self->disable_sth_caching
1192 ? $dbh->prepare($sql)
1193 : $dbh->prepare_cached($sql, {}, 3);
1194
d92a4015 1195 # XXX You would think RaiseError would make this impossible,
1196 # but apparently that's not true :(
61646ebd 1197 $self->throw_exception($dbh->errstr) if !$sth;
b33697ef 1198
1199 $sth;
d32d82f9 1200}
1201
8b445e33 1202sub sth {
cb5f2eea 1203 my ($self, $sql) = @_;
d4f16b21 1204 $self->dbh_do($self->can('_dbh_sth'), $sql);
8b445e33 1205}
1206
d4f16b21 1207sub _dbh_columns_info_for {
1208 my ($self, $dbh, $table) = @_;
a32e8402 1209
d32d82f9 1210 if ($dbh->can('column_info')) {
a953d8d9 1211 my %result;
d32d82f9 1212 eval {
1213 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1214 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1215 $sth->execute();
1216 while ( my $info = $sth->fetchrow_hashref() ){
1217 my %column_info;
1218 $column_info{data_type} = $info->{TYPE_NAME};
1219 $column_info{size} = $info->{COLUMN_SIZE};
1220 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1221 $column_info{default_value} = $info->{COLUMN_DEF};
1222 my $col_name = $info->{COLUMN_NAME};
1223 $col_name =~ s/^\"(.*)\"$/$1/;
1224
1225 $result{$col_name} = \%column_info;
0d67fe74 1226 }
d32d82f9 1227 };
093fc7a6 1228 return \%result if !$@ && scalar keys %result;
d32d82f9 1229 }
0d67fe74 1230
d32d82f9 1231 my %result;
88262f96 1232 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
d32d82f9 1233 $sth->execute;
1234 my @columns = @{$sth->{NAME_lc}};
1235 for my $i ( 0 .. $#columns ){
1236 my %column_info;
248bf0d0 1237 $column_info{data_type} = $sth->{TYPE}->[$i];
d32d82f9 1238 $column_info{size} = $sth->{PRECISION}->[$i];
1239 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
0d67fe74 1240
d32d82f9 1241 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1242 $column_info{data_type} = $1;
1243 $column_info{size} = $2;
0d67fe74 1244 }
1245
d32d82f9 1246 $result{$columns[$i]} = \%column_info;
1247 }
248bf0d0 1248 $sth->finish;
1249
1250 foreach my $col (keys %result) {
1251 my $colinfo = $result{$col};
1252 my $type_num = $colinfo->{data_type};
1253 my $type_name;
1254 if(defined $type_num && $dbh->can('type_info')) {
1255 my $type_info = $dbh->type_info($type_num);
1256 $type_name = $type_info->{TYPE_NAME} if $type_info;
1257 $colinfo->{data_type} = $type_name if $type_name;
1258 }
1259 }
d32d82f9 1260
1261 return \%result;
1262}
1263
1264sub columns_info_for {
1265 my ($self, $table) = @_;
d4f16b21 1266 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
a953d8d9 1267}
1268
9b83fccd 1269=head2 last_insert_id
1270
1271Return the row id of the last insert.
1272
1273=cut
1274
d4f16b21 1275sub _dbh_last_insert_id {
1276 my ($self, $dbh, $source, $col) = @_;
1277 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1278 $dbh->func('last_insert_rowid');
1279}
1280
843f8ecd 1281sub last_insert_id {
d4f16b21 1282 my $self = shift;
1283 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
843f8ecd 1284}
1285
9b83fccd 1286=head2 sqlt_type
1287
1288Returns the database driver name.
1289
1290=cut
1291
d4f16b21 1292sub sqlt_type { shift->dbh->{Driver}->{Name} }
1c339d71 1293
a71859b4 1294=head2 bind_attribute_by_data_type
1295
1296Given a datatype from column info, returns a database specific bind attribute for
1297$dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1298just handle it.
1299
1300Generally only needed for special case column types, like bytea in postgres.
1301
1302=cut
1303
1304sub bind_attribute_by_data_type {
1305 return;
1306}
1307
58ded37e 1308=head2 create_ddl_dir
9b83fccd 1309
1310=over 4
1311
c9d2e0a2 1312=item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
9b83fccd 1313
1314=back
1315
d3b0e369 1316Creates a SQL file based on the Schema, for each of the specified
9b83fccd 1317database types, in the given directory.
1318
9b83fccd 1319=cut
1320
e673f011 1321sub create_ddl_dir
1322{
c9d2e0a2 1323 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
e673f011 1324
1325 if(!$dir || !-d $dir)
1326 {
1327 warn "No directory given, using ./\n";
1328 $dir = "./";
1329 }
1330 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1331 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1332 $version ||= $schema->VERSION || '1.x';
9e7b9292 1333 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
e673f011 1334
40dce2a5 1335 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1336 . $self->_check_sqlt_message . q{'})
1337 if !$self->_check_sqlt_version;
e673f011 1338
c9d2e0a2 1339 my $sqlt = SQL::Translator->new({
1340# debug => 1,
1341 add_drop_table => 1,
1342 });
e673f011 1343 foreach my $db (@$databases)
1344 {
1345 $sqlt->reset();
1346 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1347# $sqlt->parser_args({'DBIx::Class' => $schema);
c9d2e0a2 1348 $sqlt = $self->configure_sqlt($sqlt, $db);
e673f011 1349 $sqlt->data($schema);
1350 $sqlt->producer($db);
1351
1352 my $file;
1353 my $filename = $schema->ddl_filename($db, $dir, $version);
1354 if(-e $filename)
1355 {
c9d2e0a2 1356 warn("$filename already exists, skipping $db");
e673f011 1357 next;
1358 }
c9d2e0a2 1359
e673f011 1360 my $output = $sqlt->translate;
e673f011 1361 if(!$output)
1362 {
c9d2e0a2 1363 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
e673f011 1364 next;
1365 }
c9d2e0a2 1366 if(!open($file, ">$filename"))
1367 {
1368 $self->throw_exception("Can't open $filename for writing ($!)");
1369 next;
1370 }
e673f011 1371 print $file $output;
1372 close($file);
c9d2e0a2 1373
1374 if($preversion)
1375 {
40dce2a5 1376 require SQL::Translator::Diff;
c9d2e0a2 1377
1378 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
e2c0df8e 1379# print "Previous version $prefilename\n";
c9d2e0a2 1380 if(!-e $prefilename)
1381 {
1382 warn("No previous schema file found ($prefilename)");
1383 next;
1384 }
1385 #### We need to reparse the SQLite file we just wrote, so that
1386 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1387 ## FIXME: rip Diff to pieces!
1388# my $target_schema = $sqlt->schema;
1389# unless ( $target_schema->name ) {
1390# $target_schema->name( $filename );
1391# }
1392 my @input;
1393 push @input, {file => $prefilename, parser => $db};
1394 push @input, {file => $filename, parser => $db};
1395 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1396 my $file = $_->{'file'};
1397 my $parser = $_->{'parser'};
1398
1399 my $t = SQL::Translator->new;
1400 $t->debug( 0 );
1401 $t->trace( 0 );
1402 $t->parser( $parser ) or die $t->error;
1403 my $out = $t->translate( $file ) or die $t->error;
1404 my $schema = $t->schema;
1405 unless ( $schema->name ) {
1406 $schema->name( $file );
1407 }
1408 ($schema, $parser);
1409 } @input;
1410
1411 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1412 $target_schema, $db,
1413 {}
1414 );
1415 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1416 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1417 if(-e $difffile)
1418 {
1419 warn("$difffile already exists, skipping");
1420 next;
1421 }
1422 if(!open $file, ">$difffile")
1423 {
1424 $self->throw_exception("Can't write to $difffile ($!)");
1425 next;
1426 }
1427 print $file $diff;
1428 close($file);
1429 }
e673f011 1430 }
c9d2e0a2 1431}
e673f011 1432
c9d2e0a2 1433sub configure_sqlt() {
1434 my $self = shift;
1435 my $tr = shift;
1436 my $db = shift || $self->sqlt_type;
1437 if ($db eq 'PostgreSQL') {
1438 $tr->quote_table_names(0);
1439 $tr->quote_field_names(0);
1440 }
1441 return $tr;
e673f011 1442}
1443
9b83fccd 1444=head2 deployment_statements
1445
d3b0e369 1446=over 4
1447
1448=item Arguments: $schema, $type, $version, $directory, $sqlt_args
1449
1450=back
1451
1452Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1453The database driver name is given by C<$type>, though the value from
1454L</sqlt_type> is used if it is not specified.
1455
1456C<$directory> is used to return statements from files in a previously created
1457L</create_ddl_dir> directory and is optional. The filenames are constructed
1458from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1459
1460If no C<$directory> is specified then the statements are constructed on the
1461fly using L<SQL::Translator> and C<$version> is ignored.
1462
1463See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
9b83fccd 1464
1465=cut
1466
e673f011 1467sub deployment_statements {
1468 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
915919c5 1469 # Need to be connected to get the correct sqlt_type
c377d939 1470 $self->ensure_connected() unless $type;
e673f011 1471 $type ||= $self->sqlt_type;
1472 $version ||= $schema->VERSION || '1.x';
1473 $dir ||= './';
c9d2e0a2 1474 my $filename = $schema->ddl_filename($type, $dir, $version);
1475 if(-f $filename)
1476 {
1477 my $file;
1478 open($file, "<$filename")
1479 or $self->throw_exception("Can't open $filename ($!)");
1480 my @rows = <$file>;
1481 close($file);
1482 return join('', @rows);
1483 }
1484
40dce2a5 1485 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1486 . $self->_check_sqlt_message . q{'})
1487 if !$self->_check_sqlt_version;
1488
1489 require SQL::Translator::Parser::DBIx::Class;
1490 eval qq{use SQL::Translator::Producer::${type}};
1491 $self->throw_exception($@) if $@;
1492
1493 # sources needs to be a parser arg, but for simplicty allow at top level
1494 # coming in
1495 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1496 if exists $sqltargs->{sources};
1497
1498 my $tr = SQL::Translator->new(%$sqltargs);
1499 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1500 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
e673f011 1501
c9d2e0a2 1502 return;
e673f011 1503
1c339d71 1504}
843f8ecd 1505
1c339d71 1506sub deploy {
260129d8 1507 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1508 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
61bf0de5 1509 foreach my $line ( split(";\n", $statement)) {
1510 next if($line =~ /^--/);
1511 next if(!$line);
1512# next if($line =~ /^DROP/m);
1513 next if($line =~ /^BEGIN TRANSACTION/m);
1514 next if($line =~ /^COMMIT/m);
1515 next if $line =~ /^\s+$/; # skip whitespace only
e5d9ee92 1516 $self->_query_start($line);
61bf0de5 1517 eval {
1518 $self->dbh->do($line); # shouldn't be using ->dbh ?
1519 };
1520 if ($@) {
1521 warn qq{$@ (running "${line}")};
1522 }
e5d9ee92 1523 $self->_query_end($line);
e4fe9ba3 1524 }
75d07914 1525 }
1c339d71 1526}
843f8ecd 1527
9b83fccd 1528=head2 datetime_parser
1529
1530Returns the datetime parser class
1531
1532=cut
1533
f86fcf0d 1534sub datetime_parser {
1535 my $self = shift;
114780ee 1536 return $self->{datetime_parser} ||= do {
1537 $self->ensure_connected;
1538 $self->build_datetime_parser(@_);
1539 };
f86fcf0d 1540}
1541
9b83fccd 1542=head2 datetime_parser_type
1543
1544Defines (returns) the datetime parser class - currently hardwired to
1545L<DateTime::Format::MySQL>
1546
1547=cut
1548
f86fcf0d 1549sub datetime_parser_type { "DateTime::Format::MySQL"; }
1550
9b83fccd 1551=head2 build_datetime_parser
1552
1553See L</datetime_parser>
1554
1555=cut
1556
f86fcf0d 1557sub build_datetime_parser {
1558 my $self = shift;
1559 my $type = $self->datetime_parser_type(@_);
1560 eval "use ${type}";
1561 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1562 return $type;
1563}
1564
40dce2a5 1565{
1566 my $_check_sqlt_version; # private
1567 my $_check_sqlt_message; # private
1568 sub _check_sqlt_version {
1569 return $_check_sqlt_version if defined $_check_sqlt_version;
1570 eval 'use SQL::Translator 0.08';
1571 $_check_sqlt_message = $@ ? $@ : '';
1572 $_check_sqlt_version = $@ ? 0 : 1;
1573 }
1574
1575 sub _check_sqlt_message {
1576 _check_sqlt_version if !defined $_check_sqlt_message;
1577 $_check_sqlt_message;
1578 }
1579}
1580
c756145c 1581sub DESTROY {
1582 my $self = shift;
f5de3933 1583 return if !$self->_dbh;
c756145c 1584 $self->_verify_pid;
1585 $self->_dbh(undef);
1586}
92925617 1587
8b445e33 15881;
1589
9b83fccd 1590=head1 SQL METHODS
1591
1592The module defines a set of methods within the DBIC::SQL::Abstract
1593namespace. These build on L<SQL::Abstract::Limit> to provide the
1594SQL query functions.
1595
1596The following methods are extended:-
1597
1598=over 4
1599
1600=item delete
1601
1602=item insert
1603
1604=item select
1605
1606=item update
1607
1608=item limit_dialect
1609
2cc3a7be 1610See L</connect_info> for details.
1611For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1612
9b83fccd 1613=item quote_char
1614
2cc3a7be 1615See L</connect_info> for details.
1616For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1617
9b83fccd 1618=item name_sep
1619
2cc3a7be 1620See L</connect_info> for details.
1621For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1622
9b83fccd 1623=back
1624
8b445e33 1625=head1 AUTHORS
1626
daec44b8 1627Matt S. Trout <mst@shadowcatsystems.co.uk>
8b445e33 1628
9f19b1d6 1629Andy Grundman <andy@hybridized.org>
1630
8b445e33 1631=head1 LICENSE
1632
1633You may distribute this code under the same terms as Perl itself.
1634
1635=cut