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