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