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