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