next::method, not next::columns_info_for
[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
20a2c954 6use strict;
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;
701da8c4 13use Carp::Clan qw/DBIx::Class/;
bd7efd39 14BEGIN {
15
cb5f2eea 16package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
bd7efd39 17
18use base qw/SQL::Abstract::Limit/;
19
2cc3a7be 20# This prevents the caching of $dbh in S::A::L, I believe
21sub new {
22 my $self = shift->SUPER::new(@_);
23
24 # If limit_dialect is a ref (like a $dbh), go ahead and replace
25 # it with what it resolves to:
26 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
27 if ref $self->{limit_dialect};
28
29 $self;
30}
31
32# While we're at it, this should make LIMIT queries more efficient,
33# without digging into things too deeply
34sub _find_syntax {
35 my ($self, $syntax) = @_;
36 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
37}
38
54540863 39sub select {
40 my ($self, $table, $fields, $where, $order, @rest) = @_;
6346a152 41 $table = $self->_quote($table) unless ref($table);
eac29141 42 local $self->{rownum_hack_count} = 1
43 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
54540863 44 @rest = (-1) unless defined $rest[0];
0823196c 45 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
46 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
8839560b 47 local $self->{having_bind} = [];
bc0c9800 48 my ($sql, @ret) = $self->SUPER::select(
49 $table, $self->_recurse_fields($fields), $where, $order, @rest
50 );
8839560b 51 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
54540863 52}
53
6346a152 54sub insert {
55 my $self = shift;
56 my $table = shift;
57 $table = $self->_quote($table) unless ref($table);
58 $self->SUPER::insert($table, @_);
59}
60
61sub update {
62 my $self = shift;
63 my $table = shift;
64 $table = $self->_quote($table) unless ref($table);
65 $self->SUPER::update($table, @_);
66}
67
68sub delete {
69 my $self = shift;
70 my $table = shift;
71 $table = $self->_quote($table) unless ref($table);
72 $self->SUPER::delete($table, @_);
73}
74
54540863 75sub _emulate_limit {
76 my $self = shift;
77 if ($_[3] == -1) {
78 return $_[1].$self->_order_by($_[2]);
79 } else {
80 return $self->SUPER::_emulate_limit(@_);
81 }
82}
83
84sub _recurse_fields {
85 my ($self, $fields) = @_;
86 my $ref = ref $fields;
87 return $self->_quote($fields) unless $ref;
88 return $$fields if $ref eq 'SCALAR';
89
90 if ($ref eq 'ARRAY') {
eac29141 91 return join(', ', map {
92 $self->_recurse_fields($_)
93 .(exists $self->{rownum_hack_count}
94 ? ' AS col'.$self->{rownum_hack_count}++
95 : '')
96 } @$fields);
54540863 97 } elsif ($ref eq 'HASH') {
98 foreach my $func (keys %$fields) {
99 return $self->_sqlcase($func)
100 .'( '.$self->_recurse_fields($fields->{$func}).' )';
101 }
102 }
103}
104
105sub _order_by {
106 my $self = shift;
107 my $ret = '';
8839560b 108 my @extra;
54540863 109 if (ref $_[0] eq 'HASH') {
110 if (defined $_[0]->{group_by}) {
111 $ret = $self->_sqlcase(' group by ')
112 .$self->_recurse_fields($_[0]->{group_by});
113 }
8839560b 114 if (defined $_[0]->{having}) {
115 my $frag;
116 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
117 push(@{$self->{having_bind}}, @extra);
118 $ret .= $self->_sqlcase(' having ').$frag;
119 }
54540863 120 if (defined $_[0]->{order_by}) {
7ce5cbe7 121 $ret .= $self->_order_by($_[0]->{order_by});
54540863 122 }
d09c569a 123 } elsif (ref $_[0] eq 'SCALAR') {
e535069e 124 $ret = $self->_sqlcase(' order by ').${ $_[0] };
d09c569a 125 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
126 my @order = @{+shift};
127 $ret = $self->_sqlcase(' order by ')
128 .join(', ', map {
129 my $r = $self->_order_by($_, @_);
130 $r =~ s/^ ?ORDER BY //i;
131 $r;
132 } @order);
54540863 133 } else {
134 $ret = $self->SUPER::_order_by(@_);
135 }
136 return $ret;
137}
138
f48dd03f 139sub _order_directions {
140 my ($self, $order) = @_;
141 $order = $order->{order_by} if ref $order eq 'HASH';
142 return $self->SUPER::_order_directions($order);
143}
144
2a816814 145sub _table {
bd7efd39 146 my ($self, $from) = @_;
147 if (ref $from eq 'ARRAY') {
148 return $self->_recurse_from(@$from);
149 } elsif (ref $from eq 'HASH') {
150 return $self->_make_as($from);
151 } else {
6346a152 152 return $from; # would love to quote here but _table ends up getting called
153 # twice during an ->select without a limit clause due to
154 # the way S::A::Limit->select works. should maybe consider
155 # bypassing this and doing S::A::select($self, ...) in
156 # our select method above. meantime, quoting shims have
157 # been added to select/insert/update/delete here
bd7efd39 158 }
159}
160
161sub _recurse_from {
162 my ($self, $from, @join) = @_;
163 my @sqlf;
164 push(@sqlf, $self->_make_as($from));
165 foreach my $j (@join) {
166 my ($to, $on) = @$j;
73856587 167
54540863 168 # check whether a join type exists
169 my $join_clause = '';
ca7b9fdf 170 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
171 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
172 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
54540863 173 } else {
174 $join_clause = ' JOIN ';
175 }
73856587 176 push(@sqlf, $join_clause);
177
bd7efd39 178 if (ref $to eq 'ARRAY') {
179 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
180 } else {
96cdbbab 181 push(@sqlf, $self->_make_as($to));
bd7efd39 182 }
183 push(@sqlf, ' ON ', $self->_join_condition($on));
184 }
185 return join('', @sqlf);
186}
187
188sub _make_as {
189 my ($self, $from) = @_;
54540863 190 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
bc0c9800 191 reverse each %{$self->_skip_options($from)});
73856587 192}
193
194sub _skip_options {
54540863 195 my ($self, $hash) = @_;
196 my $clean_hash = {};
197 $clean_hash->{$_} = $hash->{$_}
198 for grep {!/^-/} keys %$hash;
199 return $clean_hash;
bd7efd39 200}
201
202sub _join_condition {
203 my ($self, $cond) = @_;
5efe4c79 204 if (ref $cond eq 'HASH') {
205 my %j;
bc0c9800 206 for (keys %$cond) {
207 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
208 };
5efe4c79 209 return $self->_recurse_where(\%j);
210 } elsif (ref $cond eq 'ARRAY') {
211 return join(' OR ', map { $self->_join_condition($_) } @$cond);
212 } else {
213 die "Can't handle this yet!";
214 }
bd7efd39 215}
216
2a816814 217sub _quote {
218 my ($self, $label) = @_;
219 return '' unless defined $label;
3b24f6ea 220 return "*" if $label eq '*';
41728a6e 221 return $label unless $self->{quote_char};
3b24f6ea 222 if(ref $self->{quote_char} eq "ARRAY"){
223 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
224 if !defined $self->{name_sep};
225 my $sep = $self->{name_sep};
226 return join($self->{name_sep},
227 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
228 split(/\Q$sep\E/,$label));
229 }
2a816814 230 return $self->SUPER::_quote($label);
231}
232
7be93b07 233sub limit_dialect {
234 my $self = shift;
235 $self->{limit_dialect} = shift if @_;
236 return $self->{limit_dialect};
237}
238
2437a1e3 239sub quote_char {
240 my $self = shift;
241 $self->{quote_char} = shift if @_;
242 return $self->{quote_char};
243}
244
245sub name_sep {
246 my $self = shift;
247 $self->{name_sep} = shift if @_;
248 return $self->{name_sep};
249}
250
bd7efd39 251} # End of BEGIN block
252
8b445e33 253use base qw/DBIx::Class/;
254
1f692767 255__PACKAGE__->load_components(qw/AccessorGroup/);
8b445e33 256
223b8fe3 257__PACKAGE__->mk_group_accessors('simple' =>
2cc3a7be 258 qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
259 debug debugobj cursor on_connect_do transaction_depth/);
8091aa91 260
b327f988 261=head1 NAME
262
263DBIx::Class::Storage::DBI - DBI storage handler
264
265=head1 SYNOPSIS
266
267=head1 DESCRIPTION
268
269This class represents the connection to the database
270
271=head1 METHODS
272
9b83fccd 273=head2 new
274
275=cut
276
8b445e33 277sub new {
223b8fe3 278 my $new = bless({}, ref $_[0] || $_[0]);
28927b50 279 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
d79f59b9 280 $new->transaction_depth(0);
4c248161 281
282 $new->debugobj(new DBIx::Class::Storage::Statistics());
283
284 my $fh;
6fe735fa 285
286 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
287 || $ENV{DBIC_TRACE};
288
289 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
4c248161 290 $fh = IO::File->new($1, 'w')
bc0c9800 291 or $new->throw_exception("Cannot open trace file $1");
92b858c9 292 } else {
4c248161 293 $fh = IO::File->new('>&STDERR');
92b858c9 294 }
004d31fb 295 $new->debugfh($fh);
6fe735fa 296 $new->debug(1) if $debug_env;
2cc3a7be 297 $new->_sql_maker_opts({});
223b8fe3 298 return $new;
8b445e33 299}
300
9b83fccd 301=head2 throw_exception
302
303Throws an exception - croaks.
304
305=cut
306
1c339d71 307sub throw_exception {
308 my ($self, $msg) = @_;
3b042bcb 309 croak($msg);
1c339d71 310}
311
1b45b01e 312=head2 connect_info
313
bb4f246d 314The arguments of C<connect_info> are always a single array reference.
1b45b01e 315
bb4f246d 316This is normally accessed via L<DBIx::Class::Schema/connection>, which
317encapsulates its argument list in an arrayref before calling
318C<connect_info> here.
1b45b01e 319
bb4f246d 320The arrayref can either contain the same set of arguments one would
321normally pass to L<DBI/connect>, or a lone code reference which returns
322a connected database handle.
d7c4c15c 323
2cc3a7be 324In either case, if the final argument in your connect_info happens
325to be a hashref, C<connect_info> will look there for several
326connection-specific options:
327
328=over 4
329
330=item on_connect_do
331
332This can be set to an arrayref of literal sql statements, which will
333be executed immediately after making the connection to the database
334every time we [re-]connect.
335
336=item limit_dialect
337
338Sets the limit dialect. This is useful for JDBC-bridge among others
339where the remote SQL-dialect cannot be determined by the name of the
340driver alone.
341
342=item quote_char
d7c4c15c 343
2cc3a7be 344Specifies what characters to use to quote table and column names. If
345you use this you will want to specify L<name_sep> as well.
346
347quote_char expects either a single character, in which case is it is placed
348on either side of the table/column, or an arrayref of length 2 in which case the
349table/column name is placed between the elements.
350
351For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
352use C<quote_char =E<gt> [qw/[ ]/]>.
353
354=item name_sep
355
356This only needs to be used in conjunction with L<quote_char>, and is used to
357specify the charecter that seperates elements (schemas, tables, columns) from
358each other. In most cases this is simply a C<.>.
359
360=back
361
362These options can be mixed in with your other L<DBI> connection attributes,
363or placed in a seperate hashref after all other normal L<DBI> connection
364arguments.
365
366Every time C<connect_info> is invoked, any previous settings for
367these options will be cleared before setting the new ones, regardless of
368whether any options are specified in the new C<connect_info>.
369
370Examples:
371
372 # Simple SQLite connection
bb4f246d 373 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
6789ebe3 374
2cc3a7be 375 # Connect via subref
bb4f246d 376 ->connect_info([ sub { DBI->connect(...) } ]);
6789ebe3 377
2cc3a7be 378 # A bit more complicated
bb4f246d 379 ->connect_info(
380 [
381 'dbi:Pg:dbname=foo',
382 'postgres',
383 'my_pg_password',
384 { AutoCommit => 0 },
2cc3a7be 385 { quote_char => q{"}, name_sep => q{.} },
386 ]
387 );
388
389 # Equivalent to the previous example
390 ->connect_info(
391 [
392 'dbi:Pg:dbname=foo',
393 'postgres',
394 'my_pg_password',
395 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
bb4f246d 396 ]
397 );
6789ebe3 398
2cc3a7be 399 # Subref + DBIC-specific connection options
bb4f246d 400 ->connect_info(
401 [
402 sub { DBI->connect(...) },
2cc3a7be 403 {
404 quote_char => q{`},
405 name_sep => q{@},
406 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
407 },
bb4f246d 408 ]
409 );
6789ebe3 410
bb4f246d 411=head2 on_connect_do
6789ebe3 412
2cc3a7be 413This method is deprecated in favor of setting via L</connect_info>.
6789ebe3 414
92b858c9 415=head2 debug
416
4c248161 417Causes SQL trace information to be emitted on the C<debugobj> object.
418(or C<STDERR> if C<debugobj> has not specifically been set).
92b858c9 419
f7a90adc 420This is the equivalent to setting L</DBIC_TRACE> in your
421shell environment.
422
92b858c9 423=head2 debugfh
424
4c248161 425Set or retrieve the filehandle used for trace/debug output. This should be
426an IO::Handle compatible ojbect (only the C<print> method is used. Initially
427set to be STDERR - although see information on the
6fe735fa 428L<DBIC_TRACE> environment variable.
92b858c9 429
004d31fb 430=cut
431
432sub debugfh {
433 my $self = shift;
434
435 if ($self->debugobj->can('debugfh')) {
436 return $self->debugobj->debugfh(@_);
437 }
438}
439
4c248161 440=head2 debugobj
441
442Sets or retrieves the object used for metric collection. Defaults to an instance
443of L<DBIx::Class::Storage::Statistics> that is campatible with the original
444method of using a coderef as a callback. See the aforementioned Statistics
445class for more information.
446
486ad69b 447=head2 debugcb
448
449Sets a callback to be executed each time a statement is run; takes a sub
4c248161 450reference. Callback is executed as $sub->($op, $info) where $op is
451SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
486ad69b 452
4c248161 453See L<debugobj> for a better way.
d7c4c15c 454
4c248161 455=cut
004d31fb 456
486ad69b 457sub debugcb {
004d31fb 458 my $self = shift;
4c248161 459
004d31fb 460 if ($self->debugobj->can('callback')) {
461 return $self->debugobj->callback(@_);
4c248161 462 }
486ad69b 463}
464
9b83fccd 465=head2 disconnect
466
467Disconnect the L<DBI> handle, performing a rollback first if the
468database is not in C<AutoCommit> mode.
469
470=cut
471
412db1f4 472sub disconnect {
473 my ($self) = @_;
474
92925617 475 if( $self->connected ) {
476 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
477 $self->_dbh->disconnect;
478 $self->_dbh(undef);
479 }
412db1f4 480}
481
9b83fccd 482=head2 connected
483
484Check if the L<DBI> handle is connected. Returns true if the handle
485is connected.
486
487=cut
488
489sub connected { my ($self) = @_;
412db1f4 490
1346e22d 491 if(my $dbh = $self->_dbh) {
492 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
1346e22d 493 return $self->_dbh(undef);
494 }
495 elsif($self->_conn_pid != $$) {
496 $self->_dbh->{InactiveDestroy} = 1;
2cc3a7be 497 return $self->_dbh(undef);
1346e22d 498 }
499 return ($dbh->FETCH('Active') && $dbh->ping);
500 }
501
502 return 0;
412db1f4 503}
504
9b83fccd 505=head2 ensure_connected
506
507Check whether the database handle is connected - if not then make a
508connection.
509
510=cut
511
412db1f4 512sub ensure_connected {
513 my ($self) = @_;
514
515 unless ($self->connected) {
8b445e33 516 $self->_populate_dbh;
517 }
412db1f4 518}
519
c235bbae 520=head2 dbh
521
522Returns the dbh - a data base handle of class L<DBI>.
523
524=cut
525
412db1f4 526sub dbh {
527 my ($self) = @_;
528
529 $self->ensure_connected;
8b445e33 530 return $self->_dbh;
531}
532
f1f56aad 533sub _sql_maker_args {
534 my ($self) = @_;
535
2cc3a7be 536 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
f1f56aad 537}
538
9b83fccd 539=head2 sql_maker
540
541Returns a C<sql_maker> object - normally an object of class
542C<DBIC::SQL::Abstract>.
543
544=cut
545
48c69e7c 546sub sql_maker {
547 my ($self) = @_;
fdc1c3d0 548 unless ($self->_sql_maker) {
f1f56aad 549 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
48c69e7c 550 }
551 return $self->_sql_maker;
552}
553
1b45b01e 554sub connect_info {
bb4f246d 555 my ($self, $info_arg) = @_;
556
557 if($info_arg) {
2cc3a7be 558 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
559 # the new set of options
560 $self->_sql_maker(undef);
561 $self->_sql_maker_opts({});
562
bb4f246d 563 my $info = [ @$info_arg ]; # copy because we can alter it
564 my $last_info = $info->[-1];
565 if(ref $last_info eq 'HASH') {
2cc3a7be 566 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
bb4f246d 567 $self->on_connect_do($on_connect_do);
568 }
569 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
2cc3a7be 570 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
571 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
1b45b01e 572 }
bb4f246d 573 }
1b45b01e 574
2cc3a7be 575 # Get rid of any trailing empty hashref
576 pop(@$info) if !keys %$last_info;
1b45b01e 577 }
578
bb4f246d 579 $self->_connect_info($info);
580 }
581
582 $self->_connect_info;
1b45b01e 583}
584
8b445e33 585sub _populate_dbh {
586 my ($self) = @_;
1b45b01e 587 my @info = @{$self->_connect_info || []};
8b445e33 588 $self->_dbh($self->_connect(@info));
2fd24e78 589
590 if(ref $self eq 'DBIx::Class::Storage::DBI') {
591 my $driver = $self->_dbh->{Driver}->{Name};
efe6365b 592 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
2fd24e78 593 bless $self, "DBIx::Class::Storage::DBI::${driver}";
594 $self->_rebless() if $self->can('_rebless');
595 }
843f8ecd 596 }
2fd24e78 597
d7c4c15c 598 # if on-connect sql statements are given execute them
599 foreach my $sql_statement (@{$self->on_connect_do || []}) {
4c248161 600 $self->debugobj->query_start($sql_statement) if $self->debug();
d7c4c15c 601 $self->_dbh->do($sql_statement);
4c248161 602 $self->debugobj->query_end($sql_statement) if $self->debug();
d7c4c15c 603 }
5ef3e508 604
1346e22d 605 $self->_conn_pid($$);
606 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
8b445e33 607}
608
609sub _connect {
610 my ($self, @info) = @_;
5ef3e508 611
9d31f7dc 612 $self->throw_exception("You failed to provide any connection info")
613 if !@info;
614
90ec6cad 615 my ($old_connect_via, $dbh);
616
5ef3e508 617 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
90ec6cad 618 $old_connect_via = $DBI::connect_via;
5ef3e508 619 $DBI::connect_via = 'connect';
5ef3e508 620 }
621
75db246c 622 eval {
bb4f246d 623 $dbh = ref $info[0] eq 'CODE'
624 ? &{$info[0]}
625 : DBI->connect(@info);
75db246c 626 };
90ec6cad 627
628 $DBI::connect_via = $old_connect_via if $old_connect_via;
629
75db246c 630 if (!$dbh || $@) {
631 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
632 }
90ec6cad 633
e571e823 634 $dbh;
8b445e33 635}
636
8091aa91 637=head2 txn_begin
8b445e33 638
8091aa91 639Calls begin_work on the current dbh.
8b445e33 640
181a28f4 641See L<DBIx::Class::Schema> for the txn_do() method, which allows for
642an entire code block to be executed transactionally.
643
8b445e33 644=cut
645
8091aa91 646sub txn_begin {
d79f59b9 647 my $self = shift;
a32e8402 648 if ($self->{transaction_depth}++ == 0) {
649 my $dbh = $self->dbh;
650 if ($dbh->{AutoCommit}) {
4c248161 651 $self->debugobj->txn_begin()
a32e8402 652 if ($self->debug);
653 $dbh->begin_work;
654 }
986e4fca 655 }
8091aa91 656}
8b445e33 657
8091aa91 658=head2 txn_commit
8b445e33 659
8091aa91 660Issues a commit against the current dbh.
8b445e33 661
8091aa91 662=cut
663
664sub txn_commit {
d79f59b9 665 my $self = shift;
7c5a8b60 666 my $dbh = $self->dbh;
d79f59b9 667 if ($self->{transaction_depth} == 0) {
a32e8402 668 unless ($dbh->{AutoCommit}) {
4c248161 669 $self->debugobj->txn_commit()
986e4fca 670 if ($self->debug);
a32e8402 671 $dbh->commit;
986e4fca 672 }
8091aa91 673 }
674 else {
986e4fca 675 if (--$self->{transaction_depth} == 0) {
4c248161 676 $self->debugobj->txn_commit()
986e4fca 677 if ($self->debug);
7c5a8b60 678 $dbh->commit;
986e4fca 679 }
8091aa91 680 }
681}
682
683=head2 txn_rollback
684
181a28f4 685Issues a rollback against the current dbh. A nested rollback will
686throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
687which allows the rollback to propagate to the outermost transaction.
8b445e33 688
689=cut
690
8091aa91 691sub txn_rollback {
d79f59b9 692 my $self = shift;
a62cf8d4 693
694 eval {
7c5a8b60 695 my $dbh = $self->dbh;
a62cf8d4 696 if ($self->{transaction_depth} == 0) {
a32e8402 697 unless ($dbh->{AutoCommit}) {
4c248161 698 $self->debugobj->txn_rollback()
986e4fca 699 if ($self->debug);
a32e8402 700 $dbh->rollback;
986e4fca 701 }
a62cf8d4 702 }
703 else {
986e4fca 704 if (--$self->{transaction_depth} == 0) {
4c248161 705 $self->debugobj->txn_rollback()
986e4fca 706 if ($self->debug);
7c5a8b60 707 $dbh->rollback;
986e4fca 708 }
709 else {
1346e22d 710 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
986e4fca 711 }
a62cf8d4 712 }
713 };
714
715 if ($@) {
716 my $error = $@;
717 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
718 $error =~ /$exception_class/ and $self->throw_exception($error);
719 $self->{transaction_depth} = 0; # ensure that a failed rollback
720 $self->throw_exception($error); # resets the transaction depth
8091aa91 721 }
722}
8b445e33 723
223b8fe3 724sub _execute {
725 my ($self, $op, $extra_bind, $ident, @args) = @_;
726 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
944f30bf 727 unshift(@bind, @$extra_bind) if $extra_bind;
f59ffc79 728 if ($self->debug) {
e673f011 729 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
4c248161 730 $self->debugobj->query_start($sql, @debug_bind);
f59ffc79 731 }
75db246c 732 my $sth = eval { $self->sth($sql,$op) };
733
734 if (!$sth || $@) {
ec0ff6f6 735 $self->throw_exception(
736 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
737 );
75db246c 738 }
438adc0e 739 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
701da8c4 740 my $rv;
75d07914 741 if ($sth) {
4c248161 742 my $time = time();
95dad7e2 743 $rv = eval { $sth->execute(@bind) };
744
745 if ($@ || !$rv) {
746 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
747 }
75d07914 748 } else {
1c339d71 749 $self->throw_exception("'$sql' did not generate a statement.");
701da8c4 750 }
4c248161 751 if ($self->debug) {
752 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
753 $self->debugobj->query_end($sql, @debug_bind);
754 }
223b8fe3 755 return (wantarray ? ($rv, $sth, @bind) : $rv);
756}
757
8b445e33 758sub insert {
759 my ($self, $ident, $to_insert) = @_;
bc0c9800 760 $self->throw_exception(
761 "Couldn't insert ".join(', ',
762 map "$_ => $to_insert->{$_}", keys %$to_insert
763 )." into ${ident}"
764 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
8b445e33 765 return $to_insert;
766}
767
768sub update {
223b8fe3 769 return shift->_execute('update' => [], @_);
8b445e33 770}
771
772sub delete {
223b8fe3 773 return shift->_execute('delete' => [], @_);
8b445e33 774}
775
de705b51 776sub _select {
8b445e33 777 my ($self, $ident, $select, $condition, $attrs) = @_;
223b8fe3 778 my $order = $attrs->{order_by};
779 if (ref $condition eq 'SCALAR') {
780 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
781 }
8839560b 782 if (exists $attrs->{group_by} || $attrs->{having}) {
bc0c9800 783 $order = {
784 group_by => $attrs->{group_by},
785 having => $attrs->{having},
786 ($order ? (order_by => $order) : ())
787 };
54540863 788 }
5c91499f 789 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
9229f20a 790 if ($attrs->{software_limit} ||
791 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
792 $attrs->{software_limit} = 1;
5c91499f 793 } else {
0823196c 794 $self->throw_exception("rows attribute must be positive if present")
795 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
5c91499f 796 push @args, $attrs->{rows}, $attrs->{offset};
797 }
de705b51 798 return $self->_execute(@args);
799}
800
9b83fccd 801=head2 select
802
803Handle a SQL select statement.
804
805=cut
806
de705b51 807sub select {
808 my $self = shift;
809 my ($ident, $select, $condition, $attrs) = @_;
cb5f2eea 810 return $self->cursor->new($self, \@_, $attrs);
8b445e33 811}
812
9b83fccd 813=head2 select_single
814
815Performs a select, fetch and return of data - handles a single row
816only.
817
818=cut
819
6157db4f 820# Need to call finish() to work round broken DBDs
821
1a14aa3f 822sub select_single {
de705b51 823 my $self = shift;
824 my ($rv, $sth, @bind) = $self->_select(@_);
6157db4f 825 my @row = $sth->fetchrow_array;
826 $sth->finish();
827 return @row;
1a14aa3f 828}
829
9b83fccd 830=head2 sth
831
832Returns a L<DBI> sth (statement handle) for the supplied SQL.
833
834=cut
835
8b445e33 836sub sth {
cb5f2eea 837 my ($self, $sql) = @_;
91fa659e 838 # 3 is the if_active parameter which avoids active sth re-use
839 return $self->dbh->prepare_cached($sql, {}, 3);
8b445e33 840}
841
a953d8d9 842=head2 columns_info_for
843
844Returns database type info for a given table columns.
845
846=cut
847
848sub columns_info_for {
0d67fe74 849 my ($self, $table) = @_;
bfe10d87 850
a32e8402 851 my $dbh = $self->dbh;
852
853 if ($dbh->can('column_info')) {
a953d8d9 854 my %result;
a32e8402 855 my $old_raise_err = $dbh->{RaiseError};
856 my $old_print_err = $dbh->{PrintError};
857 $dbh->{RaiseError} = 1;
858 $dbh->{PrintError} = 0;
0d67fe74 859 eval {
4d272ce5 860 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
861 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
0d67fe74 862 $sth->execute();
099049b5 863
864 # Some error occured or there is no information:
865 if($sth->rows <1) {
866 die "column_info returned no rows for $schema, $tab";
867 }
868
0d67fe74 869 while ( my $info = $sth->fetchrow_hashref() ){
bfe10d87 870 my %column_info;
0d67fe74 871 $column_info{data_type} = $info->{TYPE_NAME};
872 $column_info{size} = $info->{COLUMN_SIZE};
873 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
874 $column_info{default_value} = $info->{COLUMN_DEF};
0b88a5bb 875 my $col_name = $info->{COLUMN_NAME};
876 $col_name =~ s/^\"(.*)\"$/$1/;
0d67fe74 877
0b88a5bb 878 $result{$col_name} = \%column_info;
0d67fe74 879 }
880 };
a32e8402 881 $dbh->{RaiseError} = $old_raise_err;
882 $dbh->{PrintError} = $old_print_err;
0d67fe74 883 return \%result if !$@;
884 }
885
886 my %result;
a32e8402 887 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
0d67fe74 888 $sth->execute;
889 my @columns = @{$sth->{NAME_lc}};
890 for my $i ( 0 .. $#columns ){
891 my %column_info;
892 my $type_num = $sth->{TYPE}->[$i];
893 my $type_name;
a32e8402 894 if(defined $type_num && $dbh->can('type_info')) {
895 my $type_info = $dbh->type_info($type_num);
0d67fe74 896 $type_name = $type_info->{TYPE_NAME} if $type_info;
a953d8d9 897 }
0d67fe74 898 $column_info{data_type} = $type_name ? $type_name : $type_num;
899 $column_info{size} = $sth->{PRECISION}->[$i];
900 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
901
902 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
903 $column_info{data_type} = $1;
904 $column_info{size} = $2;
905 }
906
907 $result{$columns[$i]} = \%column_info;
908 }
bfe10d87 909
0d67fe74 910 return \%result;
a953d8d9 911}
912
9b83fccd 913=head2 last_insert_id
914
915Return the row id of the last insert.
916
917=cut
918
843f8ecd 919sub last_insert_id {
920 my ($self, $row) = @_;
921
922 return $self->dbh->func('last_insert_rowid');
923
924}
925
9b83fccd 926=head2 sqlt_type
927
928Returns the database driver name.
929
930=cut
931
90ec6cad 932sub sqlt_type { shift->dbh->{Driver}->{Name} }
1c339d71 933
9b83fccd 934=head2 create_ddl_dir (EXPERIMENTAL)
935
936=over 4
937
938=item Arguments: $schema \@databases, $version, $directory, $sqlt_args
939
940=back
941
942Creates an SQL file based on the Schema, for each of the specified
943database types, in the given directory.
944
945Note that this feature is currently EXPERIMENTAL and may not work correctly
946across all databases, or fully handle complex relationships.
947
948=cut
949
e673f011 950sub create_ddl_dir
951{
952 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
953
954 if(!$dir || !-d $dir)
955 {
956 warn "No directory given, using ./\n";
957 $dir = "./";
958 }
959 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
960 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
961 $version ||= $schema->VERSION || '1.x';
9e7b9292 962 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
e673f011 963
1c339d71 964 eval "use SQL::Translator";
965 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
e673f011 966
9e7b9292 967 my $sqlt = SQL::Translator->new($sqltargs);
e673f011 968 foreach my $db (@$databases)
969 {
970 $sqlt->reset();
971 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
972# $sqlt->parser_args({'DBIx::Class' => $schema);
973 $sqlt->data($schema);
974 $sqlt->producer($db);
975
976 my $file;
977 my $filename = $schema->ddl_filename($db, $dir, $version);
978 if(-e $filename)
979 {
980 $self->throw_exception("$filename already exists, skipping $db");
981 next;
982 }
983 open($file, ">$filename")
984 or $self->throw_exception("Can't open $filename for writing ($!)");
985 my $output = $sqlt->translate;
986#use Data::Dumper;
987# print join(":", keys %{$schema->source_registrations});
988# print Dumper($sqlt->schema);
989 if(!$output)
990 {
991 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
992 next;
993 }
994 print $file $output;
995 close($file);
996 }
997
998}
999
9b83fccd 1000=head2 deployment_statements
1001
1002Create the statements for L</deploy> and
1003L<DBIx::Class::Schema/deploy>.
1004
1005=cut
1006
e673f011 1007sub deployment_statements {
1008 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
915919c5 1009 # Need to be connected to get the correct sqlt_type
c377d939 1010 $self->ensure_connected() unless $type;
e673f011 1011 $type ||= $self->sqlt_type;
1012 $version ||= $schema->VERSION || '1.x';
1013 $dir ||= './';
0382d607 1014 eval "use SQL::Translator";
1015 if(!$@)
1016 {
1017 eval "use SQL::Translator::Parser::DBIx::Class;";
1018 $self->throw_exception($@) if $@;
1019 eval "use SQL::Translator::Producer::${type};";
1020 $self->throw_exception($@) if $@;
1021 my $tr = SQL::Translator->new(%$sqltargs);
1022 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1023 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1024 }
e673f011 1025
1026 my $filename = $schema->ddl_filename($type, $dir, $version);
1027 if(!-f $filename)
1028 {
0382d607 1029# $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1030 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1031 return;
e673f011 1032 }
1033 my $file;
1034 open($file, "<$filename")
1035 or $self->throw_exception("Can't open $filename ($!)");
1036 my @rows = <$file>;
1037 close($file);
1038
1039 return join('', @rows);
1040
1c339d71 1041}
843f8ecd 1042
9b83fccd 1043=head2 deploy
1044
1045Sends the appropriate statements to create or modify tables to the
1046db. This would normally be called through
1047L<DBIx::Class::Schema/deploy>.
1048
1049=cut
1050
1c339d71 1051sub deploy {
cb561d1a 1052 my ($self, $schema, $type, $sqltargs) = @_;
9e7b9292 1053 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
e4fe9ba3 1054 for ( split(";\n", $statement)) {
e673f011 1055 next if($_ =~ /^--/);
1056 next if(!$_);
1057# next if($_ =~ /^DROP/m);
1058 next if($_ =~ /^BEGIN TRANSACTION/m);
1059 next if($_ =~ /^COMMIT/m);
b489f68a 1060 next if $_ =~ /^\s+$/; # skip whitespace only
bdea30e3 1061 $self->debugobj->query_start($_) if $self->debug;
e4fe9ba3 1062 $self->dbh->do($_) or warn "SQL was:\n $_";
4c248161 1063 $self->debugobj->query_end($_) if $self->debug;
e4fe9ba3 1064 }
75d07914 1065 }
1c339d71 1066}
843f8ecd 1067
9b83fccd 1068=head2 datetime_parser
1069
1070Returns the datetime parser class
1071
1072=cut
1073
f86fcf0d 1074sub datetime_parser {
1075 my $self = shift;
1076 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1077}
1078
9b83fccd 1079=head2 datetime_parser_type
1080
1081Defines (returns) the datetime parser class - currently hardwired to
1082L<DateTime::Format::MySQL>
1083
1084=cut
1085
f86fcf0d 1086sub datetime_parser_type { "DateTime::Format::MySQL"; }
1087
9b83fccd 1088=head2 build_datetime_parser
1089
1090See L</datetime_parser>
1091
1092=cut
1093
f86fcf0d 1094sub build_datetime_parser {
1095 my $self = shift;
1096 my $type = $self->datetime_parser_type(@_);
1097 eval "use ${type}";
1098 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1099 return $type;
1100}
1101
92925617 1102sub DESTROY { shift->disconnect }
1103
8b445e33 11041;
1105
9b83fccd 1106=head1 SQL METHODS
1107
1108The module defines a set of methods within the DBIC::SQL::Abstract
1109namespace. These build on L<SQL::Abstract::Limit> to provide the
1110SQL query functions.
1111
1112The following methods are extended:-
1113
1114=over 4
1115
1116=item delete
1117
1118=item insert
1119
1120=item select
1121
1122=item update
1123
1124=item limit_dialect
1125
2cc3a7be 1126See L</connect_info> for details.
1127For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1128
9b83fccd 1129=item quote_char
1130
2cc3a7be 1131See L</connect_info> for details.
1132For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1133
9b83fccd 1134=item name_sep
1135
2cc3a7be 1136See L</connect_info> for details.
1137For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1138
9b83fccd 1139=back
1140
92b858c9 1141=head1 ENVIRONMENT VARIABLES
1142
6fe735fa 1143=head2 DBIC_TRACE
92b858c9 1144
6fe735fa 1145If C<DBIC_TRACE> is set then SQL trace information
92b858c9 1146is produced (as when the L<debug> method is set).
1147
1148If the value is of the form C<1=/path/name> then the trace output is
1149written to the file C</path/name>.
1150
d1cceec4 1151This environment variable is checked when the storage object is first
1152created (when you call connect on your schema). So, run-time changes
1153to this environment variable will not take effect unless you also
1154re-connect on your schema.
1155
6fe735fa 1156=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1157
1158Old name for DBIC_TRACE
1159
8b445e33 1160=head1 AUTHORS
1161
daec44b8 1162Matt S. Trout <mst@shadowcatsystems.co.uk>
8b445e33 1163
9f19b1d6 1164Andy Grundman <andy@hybridized.org>
1165
8b445e33 1166=head1 LICENSE
1167
1168You may distribute this code under the same terms as Perl itself.
1169
1170=cut
1171