Initial work on getting POD coverage testing working
[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 = '';
136 if (ref($to) eq 'HASH' and exists($to->{-join_type})) {
137 $join_clause = ' '.uc($to->{-join_type}).' JOIN ';
138 } else {
139 $join_clause = ' JOIN ';
140 }
73856587 141 push(@sqlf, $join_clause);
142
bd7efd39 143 if (ref $to eq 'ARRAY') {
144 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
145 } else {
96cdbbab 146 push(@sqlf, $self->_make_as($to));
bd7efd39 147 }
148 push(@sqlf, ' ON ', $self->_join_condition($on));
149 }
150 return join('', @sqlf);
151}
152
153sub _make_as {
154 my ($self, $from) = @_;
54540863 155 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
bc0c9800 156 reverse each %{$self->_skip_options($from)});
73856587 157}
158
159sub _skip_options {
54540863 160 my ($self, $hash) = @_;
161 my $clean_hash = {};
162 $clean_hash->{$_} = $hash->{$_}
163 for grep {!/^-/} keys %$hash;
164 return $clean_hash;
bd7efd39 165}
166
167sub _join_condition {
168 my ($self, $cond) = @_;
5efe4c79 169 if (ref $cond eq 'HASH') {
170 my %j;
bc0c9800 171 for (keys %$cond) {
172 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
173 };
5efe4c79 174 return $self->_recurse_where(\%j);
175 } elsif (ref $cond eq 'ARRAY') {
176 return join(' OR ', map { $self->_join_condition($_) } @$cond);
177 } else {
178 die "Can't handle this yet!";
179 }
bd7efd39 180}
181
2a816814 182sub _quote {
183 my ($self, $label) = @_;
184 return '' unless defined $label;
3b24f6ea 185 return "*" if $label eq '*';
41728a6e 186 return $label unless $self->{quote_char};
3b24f6ea 187 if(ref $self->{quote_char} eq "ARRAY"){
188 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
189 if !defined $self->{name_sep};
190 my $sep = $self->{name_sep};
191 return join($self->{name_sep},
192 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
193 split(/\Q$sep\E/,$label));
194 }
2a816814 195 return $self->SUPER::_quote($label);
196}
197
f66596f9 198sub _RowNum {
199 my $self = shift;
200 my $c;
201 $_[0] =~ s/SELECT (.*?) FROM/
202 'SELECT '.join(', ', map { $_.' AS col'.++$c } split(', ', $1)).' FROM'/e;
203 $self->SUPER::_RowNum(@_);
204}
205
7be93b07 206# Accessor for setting limit dialect. This is useful
207# for JDBC-bridge among others where the remote SQL-dialect cannot
208# be determined by the name of the driver alone.
209#
210sub limit_dialect {
211 my $self = shift;
212 $self->{limit_dialect} = shift if @_;
213 return $self->{limit_dialect};
214}
215
2437a1e3 216sub quote_char {
217 my $self = shift;
218 $self->{quote_char} = shift if @_;
219 return $self->{quote_char};
220}
221
222sub name_sep {
223 my $self = shift;
224 $self->{name_sep} = shift if @_;
225 return $self->{name_sep};
226}
227
bd7efd39 228} # End of BEGIN block
229
8b445e33 230use base qw/DBIx::Class/;
231
1f692767 232__PACKAGE__->load_components(qw/AccessorGroup/);
8b445e33 233
223b8fe3 234__PACKAGE__->mk_group_accessors('simple' =>
4c248161 235 qw/_connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugobj
1346e22d 236 cursor on_connect_do transaction_depth/);
8091aa91 237
8b445e33 238sub new {
223b8fe3 239 my $new = bless({}, ref $_[0] || $_[0]);
28927b50 240 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
d79f59b9 241 $new->transaction_depth(0);
4c248161 242
243 $new->debugobj(new DBIx::Class::Storage::Statistics());
244
245 my $fh;
5e65c358 246 if (defined($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}) &&
247 ($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} =~ /=(.+)$/)) {
4c248161 248 $fh = IO::File->new($1, 'w')
bc0c9800 249 or $new->throw_exception("Cannot open trace file $1");
92b858c9 250 } else {
4c248161 251 $fh = IO::File->new('>&STDERR');
92b858c9 252 }
004d31fb 253 $new->debugfh($fh);
28927b50 254 $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG};
223b8fe3 255 return $new;
8b445e33 256}
257
1c339d71 258sub throw_exception {
259 my ($self, $msg) = @_;
3b042bcb 260 croak($msg);
1c339d71 261}
262
75d07914 263=head1 NAME
8b445e33 264
265DBIx::Class::Storage::DBI - DBI storage handler
266
267=head1 SYNOPSIS
268
269=head1 DESCRIPTION
270
271This class represents the connection to the database
272
273=head1 METHODS
274
8b445e33 275=cut
276
1b45b01e 277=head2 connect_info
278
279Connection information arrayref. Can either be the same arguments
280one would pass to DBI->connect, or a code-reference which returns
281a connected database handle. In either case, there is an optional
282final element in the arrayref, which can hold a hashref of
283connection-specific Storage::DBI options. These include
284C<on_connect_do>, and the sql_maker options C<limit_dialect>,
285C<quote_char>, and C<name_sep>. Examples:
286
287 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
288 ->connect_info(sub { DBI->connect(...) });
289 ->connect_info([ 'dbi:Pg:dbname=foo',
290 'postgres',
291 '',
292 { AutoCommit => 0 },
293 { quote_char => q{`}, name_sep => q{@} },
294 ]);
295
d7c4c15c 296=head2 on_connect_do
297
298Executes the sql statements given as a listref on every db connect.
299
6789ebe3 300=head2 quote_char
301
302Specifies what characters to use to quote table and column names. If
303you use this you will want to specify L<name_sep> as well.
304
305quote_char expectes either a single character, in which case is it is placed
306on either side of the table/column, or an array of length 2 in which case the
307table/column name is placed between the elements.
308
309For example under MySQL you'd use C<quote_char('`')>, and user SQL Server you'd
310use C<quote_char(qw/[ ]/)>.
311
312=head2 name_sep
313
314This only needs to be used in conjunction with L<quote_char>, and is used to
315specify the charecter that seperates elements (schemas, tables, columns) from
316each other. In most cases this is simply a C<.>.
317
92b858c9 318=head2 debug
319
4c248161 320Causes SQL trace information to be emitted on the C<debugobj> object.
321(or C<STDERR> if C<debugobj> has not specifically been set).
92b858c9 322
323=head2 debugfh
324
4c248161 325Set or retrieve the filehandle used for trace/debug output. This should be
326an IO::Handle compatible ojbect (only the C<print> method is used. Initially
327set to be STDERR - although see information on the
92b858c9 328L<DBIX_CLASS_STORAGE_DBI_DEBUG> environment variable.
329
004d31fb 330=cut
331
332sub debugfh {
333 my $self = shift;
334
335 if ($self->debugobj->can('debugfh')) {
336 return $self->debugobj->debugfh(@_);
337 }
338}
339
4c248161 340=head2 debugobj
341
342Sets or retrieves the object used for metric collection. Defaults to an instance
343of L<DBIx::Class::Storage::Statistics> that is campatible with the original
344method of using a coderef as a callback. See the aforementioned Statistics
345class for more information.
346
486ad69b 347=head2 debugcb
348
349Sets a callback to be executed each time a statement is run; takes a sub
4c248161 350reference. Callback is executed as $sub->($op, $info) where $op is
351SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
486ad69b 352
4c248161 353See L<debugobj> for a better way.
d7c4c15c 354
4c248161 355=cut
004d31fb 356
486ad69b 357sub debugcb {
004d31fb 358 my $self = shift;
4c248161 359
004d31fb 360 if ($self->debugobj->can('callback')) {
361 return $self->debugobj->callback(@_);
4c248161 362 }
486ad69b 363}
364
412db1f4 365sub disconnect {
366 my ($self) = @_;
367
92925617 368 if( $self->connected ) {
369 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
370 $self->_dbh->disconnect;
371 $self->_dbh(undef);
372 }
412db1f4 373}
374
375sub connected {
8b445e33 376 my ($self) = @_;
412db1f4 377
1346e22d 378 if(my $dbh = $self->_dbh) {
379 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
380 $self->_sql_maker(undef);
381 return $self->_dbh(undef);
382 }
383 elsif($self->_conn_pid != $$) {
384 $self->_dbh->{InactiveDestroy} = 1;
385 $self->_sql_maker(undef);
386 return $self->_dbh(undef)
387 }
388 return ($dbh->FETCH('Active') && $dbh->ping);
389 }
390
391 return 0;
412db1f4 392}
393
394sub ensure_connected {
395 my ($self) = @_;
396
397 unless ($self->connected) {
8b445e33 398 $self->_populate_dbh;
399 }
412db1f4 400}
401
c235bbae 402=head2 dbh
403
404Returns the dbh - a data base handle of class L<DBI>.
405
406=cut
407
412db1f4 408sub dbh {
409 my ($self) = @_;
410
411 $self->ensure_connected;
8b445e33 412 return $self->_dbh;
413}
414
f1f56aad 415sub _sql_maker_args {
416 my ($self) = @_;
417
418 return ( limit_dialect => $self->dbh );
419}
420
48c69e7c 421sub sql_maker {
422 my ($self) = @_;
fdc1c3d0 423 unless ($self->_sql_maker) {
f1f56aad 424 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
48c69e7c 425 }
426 return $self->_sql_maker;
427}
428
1b45b01e 429sub connect_info {
430 my ($self, $info_arg) = @_;
431
432 if($info_arg) {
433 my $info = [ @$info_arg ]; # copy because we can alter it
434 my $last_info = $info->[-1];
435 if(ref $last_info eq 'HASH') {
436 my $used;
437 if(my $on_connect_do = $last_info->{on_connect_do}) {
438 $used = 1;
67008979 439 $self->on_connect_do($on_connect_do);
1b45b01e 440 }
67008979 441 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
1b45b01e 442 if(my $opt_val = $last_info->{$sql_maker_opt}) {
443 $used = 1;
444 $self->sql_maker->$sql_maker_opt($opt_val);
445 }
446 }
447
448 # remove our options hashref if it was there, to avoid confusing
449 # DBI in the case the user didn't use all 4 DBI options, as in:
450 # [ 'dbi:SQLite:foo.db', { quote_char => q{`} } ]
451 pop(@$info) if $used;
452 }
453
454 $self->_connect_info($info);
455 }
456
457 $self->_connect_info;
458}
459
8b445e33 460sub _populate_dbh {
461 my ($self) = @_;
1b45b01e 462 my @info = @{$self->_connect_info || []};
8b445e33 463 $self->_dbh($self->_connect(@info));
2a57124d 464 my $driver = $self->_dbh->{Driver}->{Name};
34470972 465 eval "require DBIx::Class::Storage::DBI::${driver}";
466 unless ($@) {
843f8ecd 467 bless $self, "DBIx::Class::Storage::DBI::${driver}";
2a57124d 468 $self->_rebless() if $self->can('_rebless');
843f8ecd 469 }
d7c4c15c 470 # if on-connect sql statements are given execute them
471 foreach my $sql_statement (@{$self->on_connect_do || []}) {
4c248161 472 $self->debugobj->query_start($sql_statement) if $self->debug();
d7c4c15c 473 $self->_dbh->do($sql_statement);
4c248161 474 $self->debugobj->query_end($sql_statement) if $self->debug();
d7c4c15c 475 }
5ef3e508 476
1346e22d 477 $self->_conn_pid($$);
478 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
8b445e33 479}
480
481sub _connect {
482 my ($self, @info) = @_;
5ef3e508 483
9d31f7dc 484 $self->throw_exception("You failed to provide any connection info")
485 if !@info;
486
90ec6cad 487 my ($old_connect_via, $dbh);
488
5ef3e508 489 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
90ec6cad 490 $old_connect_via = $DBI::connect_via;
5ef3e508 491 $DBI::connect_via = 'connect';
5ef3e508 492 }
493
75db246c 494 eval {
495 if(ref $info[0] eq 'CODE') {
496 $dbh = &{$info[0]};
497 }
498 else {
499 $dbh = DBI->connect(@info);
500 }
501 };
90ec6cad 502
503 $DBI::connect_via = $old_connect_via if $old_connect_via;
504
75db246c 505 if (!$dbh || $@) {
506 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
507 }
90ec6cad 508
e571e823 509 $dbh;
8b445e33 510}
511
8091aa91 512=head2 txn_begin
8b445e33 513
8091aa91 514Calls begin_work on the current dbh.
8b445e33 515
181a28f4 516See L<DBIx::Class::Schema> for the txn_do() method, which allows for
517an entire code block to be executed transactionally.
518
8b445e33 519=cut
520
8091aa91 521sub txn_begin {
d79f59b9 522 my $self = shift;
a32e8402 523 if ($self->{transaction_depth}++ == 0) {
524 my $dbh = $self->dbh;
525 if ($dbh->{AutoCommit}) {
4c248161 526 $self->debugobj->txn_begin()
a32e8402 527 if ($self->debug);
528 $dbh->begin_work;
529 }
986e4fca 530 }
8091aa91 531}
8b445e33 532
8091aa91 533=head2 txn_commit
8b445e33 534
8091aa91 535Issues a commit against the current dbh.
8b445e33 536
8091aa91 537=cut
538
539sub txn_commit {
d79f59b9 540 my $self = shift;
7c5a8b60 541 my $dbh = $self->dbh;
d79f59b9 542 if ($self->{transaction_depth} == 0) {
a32e8402 543 unless ($dbh->{AutoCommit}) {
4c248161 544 $self->debugobj->txn_commit()
986e4fca 545 if ($self->debug);
a32e8402 546 $dbh->commit;
986e4fca 547 }
8091aa91 548 }
549 else {
986e4fca 550 if (--$self->{transaction_depth} == 0) {
4c248161 551 $self->debugobj->txn_commit()
986e4fca 552 if ($self->debug);
7c5a8b60 553 $dbh->commit;
986e4fca 554 }
8091aa91 555 }
556}
557
558=head2 txn_rollback
559
181a28f4 560Issues a rollback against the current dbh. A nested rollback will
561throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
562which allows the rollback to propagate to the outermost transaction.
8b445e33 563
564=cut
565
8091aa91 566sub txn_rollback {
d79f59b9 567 my $self = shift;
a62cf8d4 568
569 eval {
7c5a8b60 570 my $dbh = $self->dbh;
a62cf8d4 571 if ($self->{transaction_depth} == 0) {
a32e8402 572 unless ($dbh->{AutoCommit}) {
4c248161 573 $self->debugobj->txn_rollback()
986e4fca 574 if ($self->debug);
a32e8402 575 $dbh->rollback;
986e4fca 576 }
a62cf8d4 577 }
578 else {
986e4fca 579 if (--$self->{transaction_depth} == 0) {
4c248161 580 $self->debugobj->txn_rollback()
986e4fca 581 if ($self->debug);
7c5a8b60 582 $dbh->rollback;
986e4fca 583 }
584 else {
1346e22d 585 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
986e4fca 586 }
a62cf8d4 587 }
588 };
589
590 if ($@) {
591 my $error = $@;
592 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
593 $error =~ /$exception_class/ and $self->throw_exception($error);
594 $self->{transaction_depth} = 0; # ensure that a failed rollback
595 $self->throw_exception($error); # resets the transaction depth
8091aa91 596 }
597}
8b445e33 598
223b8fe3 599sub _execute {
600 my ($self, $op, $extra_bind, $ident, @args) = @_;
601 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
944f30bf 602 unshift(@bind, @$extra_bind) if $extra_bind;
f59ffc79 603 if ($self->debug) {
e673f011 604 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
4c248161 605 $self->debugobj->query_start($sql, @debug_bind);
f59ffc79 606 }
75db246c 607 my $sth = eval { $self->sth($sql,$op) };
608
609 if (!$sth || $@) {
ec0ff6f6 610 $self->throw_exception(
611 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
612 );
75db246c 613 }
438adc0e 614 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
701da8c4 615 my $rv;
75d07914 616 if ($sth) {
4c248161 617 my $time = time();
95dad7e2 618 $rv = eval { $sth->execute(@bind) };
619
620 if ($@ || !$rv) {
621 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
622 }
75d07914 623 } else {
1c339d71 624 $self->throw_exception("'$sql' did not generate a statement.");
701da8c4 625 }
4c248161 626 if ($self->debug) {
627 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
628 $self->debugobj->query_end($sql, @debug_bind);
629 }
223b8fe3 630 return (wantarray ? ($rv, $sth, @bind) : $rv);
631}
632
8b445e33 633sub insert {
634 my ($self, $ident, $to_insert) = @_;
bc0c9800 635 $self->throw_exception(
636 "Couldn't insert ".join(', ',
637 map "$_ => $to_insert->{$_}", keys %$to_insert
638 )." into ${ident}"
639 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
8b445e33 640 return $to_insert;
641}
642
643sub update {
223b8fe3 644 return shift->_execute('update' => [], @_);
8b445e33 645}
646
647sub delete {
223b8fe3 648 return shift->_execute('delete' => [], @_);
8b445e33 649}
650
de705b51 651sub _select {
8b445e33 652 my ($self, $ident, $select, $condition, $attrs) = @_;
223b8fe3 653 my $order = $attrs->{order_by};
654 if (ref $condition eq 'SCALAR') {
655 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
656 }
8839560b 657 if (exists $attrs->{group_by} || $attrs->{having}) {
bc0c9800 658 $order = {
659 group_by => $attrs->{group_by},
660 having => $attrs->{having},
661 ($order ? (order_by => $order) : ())
662 };
54540863 663 }
5c91499f 664 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
9229f20a 665 if ($attrs->{software_limit} ||
666 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
667 $attrs->{software_limit} = 1;
5c91499f 668 } else {
0823196c 669 $self->throw_exception("rows attribute must be positive if present")
670 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
5c91499f 671 push @args, $attrs->{rows}, $attrs->{offset};
672 }
de705b51 673 return $self->_execute(@args);
674}
675
676sub select {
677 my $self = shift;
678 my ($ident, $select, $condition, $attrs) = @_;
cb5f2eea 679 return $self->cursor->new($self, \@_, $attrs);
8b445e33 680}
681
6157db4f 682# Need to call finish() to work round broken DBDs
683
1a14aa3f 684sub select_single {
de705b51 685 my $self = shift;
686 my ($rv, $sth, @bind) = $self->_select(@_);
6157db4f 687 my @row = $sth->fetchrow_array;
688 $sth->finish();
689 return @row;
1a14aa3f 690}
691
8b445e33 692sub sth {
cb5f2eea 693 my ($self, $sql) = @_;
91fa659e 694 # 3 is the if_active parameter which avoids active sth re-use
695 return $self->dbh->prepare_cached($sql, {}, 3);
8b445e33 696}
697
a953d8d9 698=head2 columns_info_for
699
700Returns database type info for a given table columns.
701
702=cut
703
704sub columns_info_for {
0d67fe74 705 my ($self, $table) = @_;
bfe10d87 706
a32e8402 707 my $dbh = $self->dbh;
708
709 if ($dbh->can('column_info')) {
a953d8d9 710 my %result;
a32e8402 711 my $old_raise_err = $dbh->{RaiseError};
712 my $old_print_err = $dbh->{PrintError};
713 $dbh->{RaiseError} = 1;
714 $dbh->{PrintError} = 0;
0d67fe74 715 eval {
4d272ce5 716 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
717 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
0d67fe74 718 $sth->execute();
719 while ( my $info = $sth->fetchrow_hashref() ){
bfe10d87 720 my %column_info;
0d67fe74 721 $column_info{data_type} = $info->{TYPE_NAME};
722 $column_info{size} = $info->{COLUMN_SIZE};
723 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
724 $column_info{default_value} = $info->{COLUMN_DEF};
0b88a5bb 725 my $col_name = $info->{COLUMN_NAME};
726 $col_name =~ s/^\"(.*)\"$/$1/;
0d67fe74 727
0b88a5bb 728 $result{$col_name} = \%column_info;
0d67fe74 729 }
730 };
a32e8402 731 $dbh->{RaiseError} = $old_raise_err;
732 $dbh->{PrintError} = $old_print_err;
0d67fe74 733 return \%result if !$@;
734 }
735
736 my %result;
a32e8402 737 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
0d67fe74 738 $sth->execute;
739 my @columns = @{$sth->{NAME_lc}};
740 for my $i ( 0 .. $#columns ){
741 my %column_info;
742 my $type_num = $sth->{TYPE}->[$i];
743 my $type_name;
a32e8402 744 if(defined $type_num && $dbh->can('type_info')) {
745 my $type_info = $dbh->type_info($type_num);
0d67fe74 746 $type_name = $type_info->{TYPE_NAME} if $type_info;
a953d8d9 747 }
0d67fe74 748 $column_info{data_type} = $type_name ? $type_name : $type_num;
749 $column_info{size} = $sth->{PRECISION}->[$i];
750 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
751
752 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
753 $column_info{data_type} = $1;
754 $column_info{size} = $2;
755 }
756
757 $result{$columns[$i]} = \%column_info;
758 }
bfe10d87 759
0d67fe74 760 return \%result;
a953d8d9 761}
762
843f8ecd 763sub last_insert_id {
764 my ($self, $row) = @_;
765
766 return $self->dbh->func('last_insert_rowid');
767
768}
769
90ec6cad 770sub sqlt_type { shift->dbh->{Driver}->{Name} }
1c339d71 771
e673f011 772sub create_ddl_dir
773{
774 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
775
776 if(!$dir || !-d $dir)
777 {
778 warn "No directory given, using ./\n";
779 $dir = "./";
780 }
781 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
782 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
783 $version ||= $schema->VERSION || '1.x';
784
1c339d71 785 eval "use SQL::Translator";
786 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
e673f011 787
788 my $sqlt = SQL::Translator->new({
789# debug => 1,
790 add_drop_table => 1,
791 });
792 foreach my $db (@$databases)
793 {
794 $sqlt->reset();
795 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
796# $sqlt->parser_args({'DBIx::Class' => $schema);
797 $sqlt->data($schema);
798 $sqlt->producer($db);
799
800 my $file;
801 my $filename = $schema->ddl_filename($db, $dir, $version);
802 if(-e $filename)
803 {
804 $self->throw_exception("$filename already exists, skipping $db");
805 next;
806 }
807 open($file, ">$filename")
808 or $self->throw_exception("Can't open $filename for writing ($!)");
809 my $output = $sqlt->translate;
810#use Data::Dumper;
811# print join(":", keys %{$schema->source_registrations});
812# print Dumper($sqlt->schema);
813 if(!$output)
814 {
815 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
816 next;
817 }
818 print $file $output;
819 close($file);
820 }
821
822}
823
824sub deployment_statements {
825 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
826 $type ||= $self->sqlt_type;
827 $version ||= $schema->VERSION || '1.x';
828 $dir ||= './';
0382d607 829 eval "use SQL::Translator";
830 if(!$@)
831 {
832 eval "use SQL::Translator::Parser::DBIx::Class;";
833 $self->throw_exception($@) if $@;
834 eval "use SQL::Translator::Producer::${type};";
835 $self->throw_exception($@) if $@;
836 my $tr = SQL::Translator->new(%$sqltargs);
837 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
838 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
839 }
e673f011 840
841 my $filename = $schema->ddl_filename($type, $dir, $version);
842 if(!-f $filename)
843 {
0382d607 844# $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
845 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
846 return;
e673f011 847 }
848 my $file;
849 open($file, "<$filename")
850 or $self->throw_exception("Can't open $filename ($!)");
851 my @rows = <$file>;
852 close($file);
853
854 return join('', @rows);
855
1c339d71 856}
843f8ecd 857
1c339d71 858sub deploy {
cb561d1a 859 my ($self, $schema, $type, $sqltargs) = @_;
e673f011 860 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, $sqltargs) ) {
e4fe9ba3 861 for ( split(";\n", $statement)) {
e673f011 862 next if($_ =~ /^--/);
863 next if(!$_);
864# next if($_ =~ /^DROP/m);
865 next if($_ =~ /^BEGIN TRANSACTION/m);
866 next if($_ =~ /^COMMIT/m);
4c248161 867 $self->debugobj->query_begin($_) if $self->debug;
e4fe9ba3 868 $self->dbh->do($_) or warn "SQL was:\n $_";
4c248161 869 $self->debugobj->query_end($_) if $self->debug;
e4fe9ba3 870 }
75d07914 871 }
1c339d71 872}
843f8ecd 873
f86fcf0d 874sub datetime_parser {
875 my $self = shift;
876 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
877}
878
879sub datetime_parser_type { "DateTime::Format::MySQL"; }
880
881sub build_datetime_parser {
882 my $self = shift;
883 my $type = $self->datetime_parser_type(@_);
884 eval "use ${type}";
885 $self->throw_exception("Couldn't load ${type}: $@") if $@;
886 return $type;
887}
888
92925617 889sub DESTROY { shift->disconnect }
890
8b445e33 8911;
892
92b858c9 893=head1 ENVIRONMENT VARIABLES
894
895=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
896
897If C<DBIX_CLASS_STORAGE_DBI_DEBUG> is set then SQL trace information
898is produced (as when the L<debug> method is set).
899
900If the value is of the form C<1=/path/name> then the trace output is
901written to the file C</path/name>.
902
d1cceec4 903This environment variable is checked when the storage object is first
904created (when you call connect on your schema). So, run-time changes
905to this environment variable will not take effect unless you also
906re-connect on your schema.
907
8b445e33 908=head1 AUTHORS
909
daec44b8 910Matt S. Trout <mst@shadowcatsystems.co.uk>
8b445e33 911
9f19b1d6 912Andy Grundman <andy@hybridized.org>
913
8b445e33 914=head1 LICENSE
915
916You may distribute this code under the same terms as Perl itself.
917
918=cut
919