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