Changed the docs for relationship attributes, and added rel order_by example
[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 {
04786a4c 278 my $new = {};
279 bless $new, (ref $_[0] || $_[0]);
280
28927b50 281 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
d79f59b9 282 $new->transaction_depth(0);
4c248161 283
284 $new->debugobj(new DBIx::Class::Storage::Statistics());
285
286 my $fh;
6fe735fa 287
288 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
289 || $ENV{DBIC_TRACE};
290
291 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
4c248161 292 $fh = IO::File->new($1, 'w')
bc0c9800 293 or $new->throw_exception("Cannot open trace file $1");
92b858c9 294 } else {
4c248161 295 $fh = IO::File->new('>&STDERR');
92b858c9 296 }
004d31fb 297 $new->debugfh($fh);
6fe735fa 298 $new->debug(1) if $debug_env;
2cc3a7be 299 $new->_sql_maker_opts({});
223b8fe3 300 return $new;
8b445e33 301}
302
9b83fccd 303=head2 throw_exception
304
305Throws an exception - croaks.
306
307=cut
308
1c339d71 309sub throw_exception {
310 my ($self, $msg) = @_;
3b042bcb 311 croak($msg);
1c339d71 312}
313
1b45b01e 314=head2 connect_info
315
bb4f246d 316The arguments of C<connect_info> are always a single array reference.
1b45b01e 317
bb4f246d 318This is normally accessed via L<DBIx::Class::Schema/connection>, which
319encapsulates its argument list in an arrayref before calling
320C<connect_info> here.
1b45b01e 321
bb4f246d 322The arrayref can either contain the same set of arguments one would
323normally pass to L<DBI/connect>, or a lone code reference which returns
324a connected database handle.
d7c4c15c 325
2cc3a7be 326In either case, if the final argument in your connect_info happens
327to be a hashref, C<connect_info> will look there for several
328connection-specific options:
329
330=over 4
331
332=item on_connect_do
333
334This can be set to an arrayref of literal sql statements, which will
335be executed immediately after making the connection to the database
336every time we [re-]connect.
337
338=item limit_dialect
339
340Sets the limit dialect. This is useful for JDBC-bridge among others
341where the remote SQL-dialect cannot be determined by the name of the
342driver alone.
343
344=item quote_char
d7c4c15c 345
2cc3a7be 346Specifies what characters to use to quote table and column names. If
347you use this you will want to specify L<name_sep> as well.
348
349quote_char expects either a single character, in which case is it is placed
350on either side of the table/column, or an arrayref of length 2 in which case the
351table/column name is placed between the elements.
352
353For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
354use C<quote_char =E<gt> [qw/[ ]/]>.
355
356=item name_sep
357
358This only needs to be used in conjunction with L<quote_char>, and is used to
359specify the charecter that seperates elements (schemas, tables, columns) from
360each other. In most cases this is simply a C<.>.
361
362=back
363
364These options can be mixed in with your other L<DBI> connection attributes,
365or placed in a seperate hashref after all other normal L<DBI> connection
366arguments.
367
368Every time C<connect_info> is invoked, any previous settings for
369these options will be cleared before setting the new ones, regardless of
370whether any options are specified in the new C<connect_info>.
371
372Examples:
373
374 # Simple SQLite connection
bb4f246d 375 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
6789ebe3 376
2cc3a7be 377 # Connect via subref
bb4f246d 378 ->connect_info([ sub { DBI->connect(...) } ]);
6789ebe3 379
2cc3a7be 380 # A bit more complicated
bb4f246d 381 ->connect_info(
382 [
383 'dbi:Pg:dbname=foo',
384 'postgres',
385 'my_pg_password',
386 { AutoCommit => 0 },
2cc3a7be 387 { quote_char => q{"}, name_sep => q{.} },
388 ]
389 );
390
391 # Equivalent to the previous example
392 ->connect_info(
393 [
394 'dbi:Pg:dbname=foo',
395 'postgres',
396 'my_pg_password',
397 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
bb4f246d 398 ]
399 );
6789ebe3 400
2cc3a7be 401 # Subref + DBIC-specific connection options
bb4f246d 402 ->connect_info(
403 [
404 sub { DBI->connect(...) },
2cc3a7be 405 {
406 quote_char => q{`},
407 name_sep => q{@},
408 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
409 },
bb4f246d 410 ]
411 );
6789ebe3 412
bb4f246d 413=head2 on_connect_do
6789ebe3 414
2cc3a7be 415This method is deprecated in favor of setting via L</connect_info>.
6789ebe3 416
92b858c9 417=head2 debug
418
4c248161 419Causes SQL trace information to be emitted on the C<debugobj> object.
420(or C<STDERR> if C<debugobj> has not specifically been set).
92b858c9 421
f7a90adc 422This is the equivalent to setting L</DBIC_TRACE> in your
423shell environment.
424
92b858c9 425=head2 debugfh
426
4c248161 427Set or retrieve the filehandle used for trace/debug output. This should be
428an IO::Handle compatible ojbect (only the C<print> method is used. Initially
429set to be STDERR - although see information on the
6fe735fa 430L<DBIC_TRACE> environment variable.
92b858c9 431
004d31fb 432=cut
433
434sub debugfh {
435 my $self = shift;
436
437 if ($self->debugobj->can('debugfh')) {
438 return $self->debugobj->debugfh(@_);
439 }
440}
441
4c248161 442=head2 debugobj
443
444Sets or retrieves the object used for metric collection. Defaults to an instance
445of L<DBIx::Class::Storage::Statistics> that is campatible with the original
446method of using a coderef as a callback. See the aforementioned Statistics
447class for more information.
448
486ad69b 449=head2 debugcb
450
451Sets a callback to be executed each time a statement is run; takes a sub
4c248161 452reference. Callback is executed as $sub->($op, $info) where $op is
453SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
486ad69b 454
4c248161 455See L<debugobj> for a better way.
d7c4c15c 456
4c248161 457=cut
004d31fb 458
486ad69b 459sub debugcb {
004d31fb 460 my $self = shift;
4c248161 461
004d31fb 462 if ($self->debugobj->can('callback')) {
463 return $self->debugobj->callback(@_);
4c248161 464 }
486ad69b 465}
466
9b83fccd 467=head2 disconnect
468
469Disconnect the L<DBI> handle, performing a rollback first if the
470database is not in C<AutoCommit> mode.
471
472=cut
473
412db1f4 474sub disconnect {
475 my ($self) = @_;
476
92925617 477 if( $self->connected ) {
478 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
479 $self->_dbh->disconnect;
480 $self->_dbh(undef);
481 }
412db1f4 482}
483
9b83fccd 484=head2 connected
485
486Check if the L<DBI> handle is connected. Returns true if the handle
487is connected.
488
489=cut
490
491sub connected { my ($self) = @_;
412db1f4 492
1346e22d 493 if(my $dbh = $self->_dbh) {
494 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
1346e22d 495 return $self->_dbh(undef);
496 }
497 elsif($self->_conn_pid != $$) {
498 $self->_dbh->{InactiveDestroy} = 1;
2cc3a7be 499 return $self->_dbh(undef);
1346e22d 500 }
501 return ($dbh->FETCH('Active') && $dbh->ping);
502 }
503
504 return 0;
412db1f4 505}
506
9b83fccd 507=head2 ensure_connected
508
509Check whether the database handle is connected - if not then make a
510connection.
511
512=cut
513
412db1f4 514sub ensure_connected {
515 my ($self) = @_;
516
517 unless ($self->connected) {
8b445e33 518 $self->_populate_dbh;
519 }
412db1f4 520}
521
c235bbae 522=head2 dbh
523
524Returns the dbh - a data base handle of class L<DBI>.
525
526=cut
527
412db1f4 528sub dbh {
529 my ($self) = @_;
530
531 $self->ensure_connected;
8b445e33 532 return $self->_dbh;
533}
534
f1f56aad 535sub _sql_maker_args {
536 my ($self) = @_;
537
2cc3a7be 538 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
f1f56aad 539}
540
9b83fccd 541=head2 sql_maker
542
543Returns a C<sql_maker> object - normally an object of class
544C<DBIC::SQL::Abstract>.
545
546=cut
547
48c69e7c 548sub sql_maker {
549 my ($self) = @_;
fdc1c3d0 550 unless ($self->_sql_maker) {
f1f56aad 551 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
48c69e7c 552 }
553 return $self->_sql_maker;
554}
555
1b45b01e 556sub connect_info {
bb4f246d 557 my ($self, $info_arg) = @_;
558
559 if($info_arg) {
2cc3a7be 560 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
561 # the new set of options
562 $self->_sql_maker(undef);
563 $self->_sql_maker_opts({});
564
bb4f246d 565 my $info = [ @$info_arg ]; # copy because we can alter it
566 my $last_info = $info->[-1];
567 if(ref $last_info eq 'HASH') {
2cc3a7be 568 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
bb4f246d 569 $self->on_connect_do($on_connect_do);
570 }
571 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
2cc3a7be 572 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
573 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
1b45b01e 574 }
bb4f246d 575 }
1b45b01e 576
2cc3a7be 577 # Get rid of any trailing empty hashref
578 pop(@$info) if !keys %$last_info;
1b45b01e 579 }
580
bb4f246d 581 $self->_connect_info($info);
582 }
583
584 $self->_connect_info;
1b45b01e 585}
586
8b445e33 587sub _populate_dbh {
588 my ($self) = @_;
1b45b01e 589 my @info = @{$self->_connect_info || []};
8b445e33 590 $self->_dbh($self->_connect(@info));
2fd24e78 591
592 if(ref $self eq 'DBIx::Class::Storage::DBI') {
593 my $driver = $self->_dbh->{Driver}->{Name};
efe6365b 594 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
2fd24e78 595 bless $self, "DBIx::Class::Storage::DBI::${driver}";
596 $self->_rebless() if $self->can('_rebless');
597 }
843f8ecd 598 }
2fd24e78 599
d7c4c15c 600 # if on-connect sql statements are given execute them
601 foreach my $sql_statement (@{$self->on_connect_do || []}) {
4c248161 602 $self->debugobj->query_start($sql_statement) if $self->debug();
d7c4c15c 603 $self->_dbh->do($sql_statement);
4c248161 604 $self->debugobj->query_end($sql_statement) if $self->debug();
d7c4c15c 605 }
5ef3e508 606
1346e22d 607 $self->_conn_pid($$);
608 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
8b445e33 609}
610
611sub _connect {
612 my ($self, @info) = @_;
5ef3e508 613
9d31f7dc 614 $self->throw_exception("You failed to provide any connection info")
615 if !@info;
616
90ec6cad 617 my ($old_connect_via, $dbh);
618
5ef3e508 619 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
90ec6cad 620 $old_connect_via = $DBI::connect_via;
5ef3e508 621 $DBI::connect_via = 'connect';
5ef3e508 622 }
623
75db246c 624 eval {
bb4f246d 625 $dbh = ref $info[0] eq 'CODE'
626 ? &{$info[0]}
627 : DBI->connect(@info);
75db246c 628 };
90ec6cad 629
630 $DBI::connect_via = $old_connect_via if $old_connect_via;
631
75db246c 632 if (!$dbh || $@) {
633 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
634 }
90ec6cad 635
e571e823 636 $dbh;
8b445e33 637}
638
8091aa91 639=head2 txn_begin
8b445e33 640
8091aa91 641Calls begin_work on the current dbh.
8b445e33 642
181a28f4 643See L<DBIx::Class::Schema> for the txn_do() method, which allows for
644an entire code block to be executed transactionally.
645
8b445e33 646=cut
647
8091aa91 648sub txn_begin {
d79f59b9 649 my $self = shift;
a32e8402 650 if ($self->{transaction_depth}++ == 0) {
651 my $dbh = $self->dbh;
652 if ($dbh->{AutoCommit}) {
4c248161 653 $self->debugobj->txn_begin()
a32e8402 654 if ($self->debug);
655 $dbh->begin_work;
656 }
986e4fca 657 }
8091aa91 658}
8b445e33 659
8091aa91 660=head2 txn_commit
8b445e33 661
8091aa91 662Issues a commit against the current dbh.
8b445e33 663
8091aa91 664=cut
665
666sub txn_commit {
d79f59b9 667 my $self = shift;
7c5a8b60 668 my $dbh = $self->dbh;
d79f59b9 669 if ($self->{transaction_depth} == 0) {
a32e8402 670 unless ($dbh->{AutoCommit}) {
4c248161 671 $self->debugobj->txn_commit()
986e4fca 672 if ($self->debug);
a32e8402 673 $dbh->commit;
986e4fca 674 }
8091aa91 675 }
676 else {
986e4fca 677 if (--$self->{transaction_depth} == 0) {
4c248161 678 $self->debugobj->txn_commit()
986e4fca 679 if ($self->debug);
7c5a8b60 680 $dbh->commit;
986e4fca 681 }
8091aa91 682 }
683}
684
685=head2 txn_rollback
686
181a28f4 687Issues a rollback against the current dbh. A nested rollback will
688throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
689which allows the rollback to propagate to the outermost transaction.
8b445e33 690
691=cut
692
8091aa91 693sub txn_rollback {
d79f59b9 694 my $self = shift;
a62cf8d4 695
696 eval {
7c5a8b60 697 my $dbh = $self->dbh;
a62cf8d4 698 if ($self->{transaction_depth} == 0) {
a32e8402 699 unless ($dbh->{AutoCommit}) {
4c248161 700 $self->debugobj->txn_rollback()
986e4fca 701 if ($self->debug);
a32e8402 702 $dbh->rollback;
986e4fca 703 }
a62cf8d4 704 }
705 else {
986e4fca 706 if (--$self->{transaction_depth} == 0) {
4c248161 707 $self->debugobj->txn_rollback()
986e4fca 708 if ($self->debug);
7c5a8b60 709 $dbh->rollback;
986e4fca 710 }
711 else {
1346e22d 712 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
986e4fca 713 }
a62cf8d4 714 }
715 };
716
717 if ($@) {
718 my $error = $@;
719 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
720 $error =~ /$exception_class/ and $self->throw_exception($error);
721 $self->{transaction_depth} = 0; # ensure that a failed rollback
722 $self->throw_exception($error); # resets the transaction depth
8091aa91 723 }
724}
8b445e33 725
223b8fe3 726sub _execute {
727 my ($self, $op, $extra_bind, $ident, @args) = @_;
728 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
944f30bf 729 unshift(@bind, @$extra_bind) if $extra_bind;
f59ffc79 730 if ($self->debug) {
e673f011 731 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
4c248161 732 $self->debugobj->query_start($sql, @debug_bind);
f59ffc79 733 }
75db246c 734 my $sth = eval { $self->sth($sql,$op) };
735
736 if (!$sth || $@) {
ec0ff6f6 737 $self->throw_exception(
738 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
739 );
75db246c 740 }
438adc0e 741 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
701da8c4 742 my $rv;
75d07914 743 if ($sth) {
4c248161 744 my $time = time();
95dad7e2 745 $rv = eval { $sth->execute(@bind) };
746
747 if ($@ || !$rv) {
748 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
749 }
75d07914 750 } else {
1c339d71 751 $self->throw_exception("'$sql' did not generate a statement.");
701da8c4 752 }
4c248161 753 if ($self->debug) {
754 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
755 $self->debugobj->query_end($sql, @debug_bind);
756 }
223b8fe3 757 return (wantarray ? ($rv, $sth, @bind) : $rv);
758}
759
8b445e33 760sub insert {
761 my ($self, $ident, $to_insert) = @_;
bc0c9800 762 $self->throw_exception(
763 "Couldn't insert ".join(', ',
764 map "$_ => $to_insert->{$_}", keys %$to_insert
765 )." into ${ident}"
766 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
8b445e33 767 return $to_insert;
768}
769
770sub update {
223b8fe3 771 return shift->_execute('update' => [], @_);
8b445e33 772}
773
774sub delete {
223b8fe3 775 return shift->_execute('delete' => [], @_);
8b445e33 776}
777
de705b51 778sub _select {
8b445e33 779 my ($self, $ident, $select, $condition, $attrs) = @_;
223b8fe3 780 my $order = $attrs->{order_by};
781 if (ref $condition eq 'SCALAR') {
782 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
783 }
8839560b 784 if (exists $attrs->{group_by} || $attrs->{having}) {
bc0c9800 785 $order = {
786 group_by => $attrs->{group_by},
787 having => $attrs->{having},
788 ($order ? (order_by => $order) : ())
789 };
54540863 790 }
5c91499f 791 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
9229f20a 792 if ($attrs->{software_limit} ||
793 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
794 $attrs->{software_limit} = 1;
5c91499f 795 } else {
0823196c 796 $self->throw_exception("rows attribute must be positive if present")
797 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
5c91499f 798 push @args, $attrs->{rows}, $attrs->{offset};
799 }
de705b51 800 return $self->_execute(@args);
801}
802
9b83fccd 803=head2 select
804
805Handle a SQL select statement.
806
807=cut
808
de705b51 809sub select {
810 my $self = shift;
811 my ($ident, $select, $condition, $attrs) = @_;
cb5f2eea 812 return $self->cursor->new($self, \@_, $attrs);
8b445e33 813}
814
9b83fccd 815=head2 select_single
816
817Performs a select, fetch and return of data - handles a single row
818only.
819
820=cut
821
6157db4f 822# Need to call finish() to work round broken DBDs
823
1a14aa3f 824sub select_single {
de705b51 825 my $self = shift;
826 my ($rv, $sth, @bind) = $self->_select(@_);
6157db4f 827 my @row = $sth->fetchrow_array;
828 $sth->finish();
829 return @row;
1a14aa3f 830}
831
9b83fccd 832=head2 sth
833
834Returns a L<DBI> sth (statement handle) for the supplied SQL.
835
836=cut
837
8b445e33 838sub sth {
cb5f2eea 839 my ($self, $sql) = @_;
91fa659e 840 # 3 is the if_active parameter which avoids active sth re-use
841 return $self->dbh->prepare_cached($sql, {}, 3);
8b445e33 842}
843
a953d8d9 844=head2 columns_info_for
845
846Returns database type info for a given table columns.
847
848=cut
849
850sub columns_info_for {
0d67fe74 851 my ($self, $table) = @_;
bfe10d87 852
a32e8402 853 my $dbh = $self->dbh;
854
855 if ($dbh->can('column_info')) {
a953d8d9 856 my %result;
955f1590 857 local $dbh->{RaiseError} = 1;
858 local $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
0d67fe74 864 while ( my $info = $sth->fetchrow_hashref() ){
bfe10d87 865 my %column_info;
0d67fe74 866 $column_info{data_type} = $info->{TYPE_NAME};
867 $column_info{size} = $info->{COLUMN_SIZE};
868 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
869 $column_info{default_value} = $info->{COLUMN_DEF};
0b88a5bb 870 my $col_name = $info->{COLUMN_NAME};
871 $col_name =~ s/^\"(.*)\"$/$1/;
0d67fe74 872
0b88a5bb 873 $result{$col_name} = \%column_info;
0d67fe74 874 }
875 };
093fc7a6 876 return \%result if !$@ && scalar keys %result;
0d67fe74 877 }
878
879 my %result;
a32e8402 880 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
0d67fe74 881 $sth->execute;
882 my @columns = @{$sth->{NAME_lc}};
883 for my $i ( 0 .. $#columns ){
884 my %column_info;
885 my $type_num = $sth->{TYPE}->[$i];
886 my $type_name;
a32e8402 887 if(defined $type_num && $dbh->can('type_info')) {
888 my $type_info = $dbh->type_info($type_num);
0d67fe74 889 $type_name = $type_info->{TYPE_NAME} if $type_info;
a953d8d9 890 }
0d67fe74 891 $column_info{data_type} = $type_name ? $type_name : $type_num;
892 $column_info{size} = $sth->{PRECISION}->[$i];
893 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
894
895 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
896 $column_info{data_type} = $1;
897 $column_info{size} = $2;
898 }
899
900 $result{$columns[$i]} = \%column_info;
901 }
bfe10d87 902
0d67fe74 903 return \%result;
a953d8d9 904}
905
9b83fccd 906=head2 last_insert_id
907
908Return the row id of the last insert.
909
910=cut
911
843f8ecd 912sub last_insert_id {
913 my ($self, $row) = @_;
914
915 return $self->dbh->func('last_insert_rowid');
916
917}
918
9b83fccd 919=head2 sqlt_type
920
921Returns the database driver name.
922
923=cut
924
90ec6cad 925sub sqlt_type { shift->dbh->{Driver}->{Name} }
1c339d71 926
9b83fccd 927=head2 create_ddl_dir (EXPERIMENTAL)
928
929=over 4
930
931=item Arguments: $schema \@databases, $version, $directory, $sqlt_args
932
933=back
934
935Creates an SQL file based on the Schema, for each of the specified
936database types, in the given directory.
937
938Note that this feature is currently EXPERIMENTAL and may not work correctly
939across all databases, or fully handle complex relationships.
940
941=cut
942
e673f011 943sub create_ddl_dir
944{
945 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
946
947 if(!$dir || !-d $dir)
948 {
949 warn "No directory given, using ./\n";
950 $dir = "./";
951 }
952 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
953 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
954 $version ||= $schema->VERSION || '1.x';
9e7b9292 955 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
e673f011 956
1c339d71 957 eval "use SQL::Translator";
958 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
e673f011 959
9e7b9292 960 my $sqlt = SQL::Translator->new($sqltargs);
e673f011 961 foreach my $db (@$databases)
962 {
963 $sqlt->reset();
964 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
965# $sqlt->parser_args({'DBIx::Class' => $schema);
966 $sqlt->data($schema);
967 $sqlt->producer($db);
968
969 my $file;
970 my $filename = $schema->ddl_filename($db, $dir, $version);
971 if(-e $filename)
972 {
973 $self->throw_exception("$filename already exists, skipping $db");
974 next;
975 }
976 open($file, ">$filename")
977 or $self->throw_exception("Can't open $filename for writing ($!)");
978 my $output = $sqlt->translate;
979#use Data::Dumper;
980# print join(":", keys %{$schema->source_registrations});
981# print Dumper($sqlt->schema);
982 if(!$output)
983 {
984 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
985 next;
986 }
987 print $file $output;
988 close($file);
989 }
990
991}
992
9b83fccd 993=head2 deployment_statements
994
995Create the statements for L</deploy> and
996L<DBIx::Class::Schema/deploy>.
997
998=cut
999
e673f011 1000sub deployment_statements {
1001 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
915919c5 1002 # Need to be connected to get the correct sqlt_type
c377d939 1003 $self->ensure_connected() unless $type;
e673f011 1004 $type ||= $self->sqlt_type;
1005 $version ||= $schema->VERSION || '1.x';
1006 $dir ||= './';
0382d607 1007 eval "use SQL::Translator";
1008 if(!$@)
1009 {
1010 eval "use SQL::Translator::Parser::DBIx::Class;";
1011 $self->throw_exception($@) if $@;
1012 eval "use SQL::Translator::Producer::${type};";
1013 $self->throw_exception($@) if $@;
1014 my $tr = SQL::Translator->new(%$sqltargs);
1015 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1016 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1017 }
e673f011 1018
1019 my $filename = $schema->ddl_filename($type, $dir, $version);
1020 if(!-f $filename)
1021 {
0382d607 1022# $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1023 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1024 return;
e673f011 1025 }
1026 my $file;
1027 open($file, "<$filename")
1028 or $self->throw_exception("Can't open $filename ($!)");
1029 my @rows = <$file>;
1030 close($file);
1031
1032 return join('', @rows);
1033
1c339d71 1034}
843f8ecd 1035
9b83fccd 1036=head2 deploy
1037
1038Sends the appropriate statements to create or modify tables to the
1039db. This would normally be called through
1040L<DBIx::Class::Schema/deploy>.
1041
1042=cut
1043
1c339d71 1044sub deploy {
cb561d1a 1045 my ($self, $schema, $type, $sqltargs) = @_;
9e7b9292 1046 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
e4fe9ba3 1047 for ( split(";\n", $statement)) {
e673f011 1048 next if($_ =~ /^--/);
1049 next if(!$_);
1050# next if($_ =~ /^DROP/m);
1051 next if($_ =~ /^BEGIN TRANSACTION/m);
1052 next if($_ =~ /^COMMIT/m);
b489f68a 1053 next if $_ =~ /^\s+$/; # skip whitespace only
bdea30e3 1054 $self->debugobj->query_start($_) if $self->debug;
e4fe9ba3 1055 $self->dbh->do($_) or warn "SQL was:\n $_";
4c248161 1056 $self->debugobj->query_end($_) if $self->debug;
e4fe9ba3 1057 }
75d07914 1058 }
1c339d71 1059}
843f8ecd 1060
9b83fccd 1061=head2 datetime_parser
1062
1063Returns the datetime parser class
1064
1065=cut
1066
f86fcf0d 1067sub datetime_parser {
1068 my $self = shift;
1069 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1070}
1071
9b83fccd 1072=head2 datetime_parser_type
1073
1074Defines (returns) the datetime parser class - currently hardwired to
1075L<DateTime::Format::MySQL>
1076
1077=cut
1078
f86fcf0d 1079sub datetime_parser_type { "DateTime::Format::MySQL"; }
1080
9b83fccd 1081=head2 build_datetime_parser
1082
1083See L</datetime_parser>
1084
1085=cut
1086
f86fcf0d 1087sub build_datetime_parser {
1088 my $self = shift;
1089 my $type = $self->datetime_parser_type(@_);
1090 eval "use ${type}";
1091 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1092 return $type;
1093}
1094
89d794d4 1095sub DESTROY {
1096 # NOTE: if there's a merge conflict here when -current is pushed
1097 # back to trunk, take -current's version and ignore this trunk one :)
1098 my $self = shift;
1099
1100 if($self->_dbh && $self->_conn_pid != $$) {
1101 $self->_dbh->{InactiveDestroy} = 1;
1102 }
1103
1104 $self->_dbh(undef);
1105}
92925617 1106
8b445e33 11071;
1108
9b83fccd 1109=head1 SQL METHODS
1110
1111The module defines a set of methods within the DBIC::SQL::Abstract
1112namespace. These build on L<SQL::Abstract::Limit> to provide the
1113SQL query functions.
1114
1115The following methods are extended:-
1116
1117=over 4
1118
1119=item delete
1120
1121=item insert
1122
1123=item select
1124
1125=item update
1126
1127=item limit_dialect
1128
2cc3a7be 1129See L</connect_info> for details.
1130For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1131
9b83fccd 1132=item quote_char
1133
2cc3a7be 1134See L</connect_info> for details.
1135For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1136
9b83fccd 1137=item name_sep
1138
2cc3a7be 1139See L</connect_info> for details.
1140For setting, this method is deprecated in favor of L</connect_info>.
bb4f246d 1141
9b83fccd 1142=back
1143
92b858c9 1144=head1 ENVIRONMENT VARIABLES
1145
6fe735fa 1146=head2 DBIC_TRACE
92b858c9 1147
6fe735fa 1148If C<DBIC_TRACE> is set then SQL trace information
92b858c9 1149is produced (as when the L<debug> method is set).
1150
1151If the value is of the form C<1=/path/name> then the trace output is
1152written to the file C</path/name>.
1153
d1cceec4 1154This environment variable is checked when the storage object is first
1155created (when you call connect on your schema). So, run-time changes
1156to this environment variable will not take effect unless you also
1157re-connect on your schema.
1158
6fe735fa 1159=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1160
1161Old name for DBIC_TRACE
1162
8b445e33 1163=head1 AUTHORS
1164
daec44b8 1165Matt S. Trout <mst@shadowcatsystems.co.uk>
8b445e33 1166
9f19b1d6 1167Andy Grundman <andy@hybridized.org>
1168
8b445e33 1169=head1 LICENSE
1170
1171You may distribute this code under the same terms as Perl itself.
1172
1173=cut
1174