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