Moved PK::Auto into core
[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 }
4c248161 253 $new->debugobj->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
92b858c9 300=head2 debug
301
4c248161 302Causes SQL trace information to be emitted on the C<debugobj> object.
303(or C<STDERR> if C<debugobj> has not specifically been set).
92b858c9 304
305=head2 debugfh
306
4c248161 307Set or retrieve the filehandle used for trace/debug output. This should be
308an IO::Handle compatible ojbect (only the C<print> method is used. Initially
309set to be STDERR - although see information on the
92b858c9 310L<DBIX_CLASS_STORAGE_DBI_DEBUG> environment variable.
311
4c248161 312=head2 debugobj
313
314Sets or retrieves the object used for metric collection. Defaults to an instance
315of L<DBIx::Class::Storage::Statistics> that is campatible with the original
316method of using a coderef as a callback. See the aforementioned Statistics
317class for more information.
318
486ad69b 319=head2 debugcb
320
321Sets a callback to be executed each time a statement is run; takes a sub
4c248161 322reference. Callback is executed as $sub->($op, $info) where $op is
323SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
486ad69b 324
4c248161 325See L<debugobj> for a better way.
d7c4c15c 326
4c248161 327=cut
486ad69b 328sub debugcb {
4c248161 329 my $self = shift();
330
331 if($self->debugobj()->can('callback')) {
332 $self->debugobj()->callback(shift());
333 }
486ad69b 334}
335
412db1f4 336sub disconnect {
337 my ($self) = @_;
338
92925617 339 if( $self->connected ) {
340 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
341 $self->_dbh->disconnect;
342 $self->_dbh(undef);
343 }
412db1f4 344}
345
346sub connected {
8b445e33 347 my ($self) = @_;
412db1f4 348
1346e22d 349 if(my $dbh = $self->_dbh) {
350 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
351 $self->_sql_maker(undef);
352 return $self->_dbh(undef);
353 }
354 elsif($self->_conn_pid != $$) {
355 $self->_dbh->{InactiveDestroy} = 1;
356 $self->_sql_maker(undef);
357 return $self->_dbh(undef)
358 }
359 return ($dbh->FETCH('Active') && $dbh->ping);
360 }
361
362 return 0;
412db1f4 363}
364
365sub ensure_connected {
366 my ($self) = @_;
367
368 unless ($self->connected) {
8b445e33 369 $self->_populate_dbh;
370 }
412db1f4 371}
372
c235bbae 373=head2 dbh
374
375Returns the dbh - a data base handle of class L<DBI>.
376
377=cut
378
412db1f4 379sub dbh {
380 my ($self) = @_;
381
382 $self->ensure_connected;
8b445e33 383 return $self->_dbh;
384}
385
f1f56aad 386sub _sql_maker_args {
387 my ($self) = @_;
388
389 return ( limit_dialect => $self->dbh );
390}
391
48c69e7c 392sub sql_maker {
393 my ($self) = @_;
fdc1c3d0 394 unless ($self->_sql_maker) {
f1f56aad 395 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
48c69e7c 396 }
397 return $self->_sql_maker;
398}
399
1b45b01e 400sub connect_info {
401 my ($self, $info_arg) = @_;
402
403 if($info_arg) {
404 my $info = [ @$info_arg ]; # copy because we can alter it
405 my $last_info = $info->[-1];
406 if(ref $last_info eq 'HASH') {
407 my $used;
408 if(my $on_connect_do = $last_info->{on_connect_do}) {
409 $used = 1;
67008979 410 $self->on_connect_do($on_connect_do);
1b45b01e 411 }
67008979 412 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
1b45b01e 413 if(my $opt_val = $last_info->{$sql_maker_opt}) {
414 $used = 1;
415 $self->sql_maker->$sql_maker_opt($opt_val);
416 }
417 }
418
419 # remove our options hashref if it was there, to avoid confusing
420 # DBI in the case the user didn't use all 4 DBI options, as in:
421 # [ 'dbi:SQLite:foo.db', { quote_char => q{`} } ]
422 pop(@$info) if $used;
423 }
424
425 $self->_connect_info($info);
426 }
427
428 $self->_connect_info;
429}
430
8b445e33 431sub _populate_dbh {
432 my ($self) = @_;
1b45b01e 433 my @info = @{$self->_connect_info || []};
8b445e33 434 $self->_dbh($self->_connect(@info));
2a57124d 435 my $driver = $self->_dbh->{Driver}->{Name};
34470972 436 eval "require DBIx::Class::Storage::DBI::${driver}";
437 unless ($@) {
843f8ecd 438 bless $self, "DBIx::Class::Storage::DBI::${driver}";
2a57124d 439 $self->_rebless() if $self->can('_rebless');
843f8ecd 440 }
d7c4c15c 441 # if on-connect sql statements are given execute them
442 foreach my $sql_statement (@{$self->on_connect_do || []}) {
4c248161 443 $self->debugobj->query_start($sql_statement) if $self->debug();
d7c4c15c 444 $self->_dbh->do($sql_statement);
4c248161 445 $self->debugobj->query_end($sql_statement) if $self->debug();
d7c4c15c 446 }
5ef3e508 447
1346e22d 448 $self->_conn_pid($$);
449 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
8b445e33 450}
451
452sub _connect {
453 my ($self, @info) = @_;
5ef3e508 454
9d31f7dc 455 $self->throw_exception("You failed to provide any connection info")
456 if !@info;
457
90ec6cad 458 my ($old_connect_via, $dbh);
459
5ef3e508 460 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
90ec6cad 461 $old_connect_via = $DBI::connect_via;
5ef3e508 462 $DBI::connect_via = 'connect';
5ef3e508 463 }
464
75db246c 465 eval {
466 if(ref $info[0] eq 'CODE') {
467 $dbh = &{$info[0]};
468 }
469 else {
470 $dbh = DBI->connect(@info);
471 }
472 };
90ec6cad 473
474 $DBI::connect_via = $old_connect_via if $old_connect_via;
475
75db246c 476 if (!$dbh || $@) {
477 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
478 }
90ec6cad 479
e571e823 480 $dbh;
8b445e33 481}
482
8091aa91 483=head2 txn_begin
8b445e33 484
8091aa91 485Calls begin_work on the current dbh.
8b445e33 486
181a28f4 487See L<DBIx::Class::Schema> for the txn_do() method, which allows for
488an entire code block to be executed transactionally.
489
8b445e33 490=cut
491
8091aa91 492sub txn_begin {
d79f59b9 493 my $self = shift;
a32e8402 494 if ($self->{transaction_depth}++ == 0) {
495 my $dbh = $self->dbh;
496 if ($dbh->{AutoCommit}) {
4c248161 497 $self->debugobj->txn_begin()
a32e8402 498 if ($self->debug);
499 $dbh->begin_work;
500 }
986e4fca 501 }
8091aa91 502}
8b445e33 503
8091aa91 504=head2 txn_commit
8b445e33 505
8091aa91 506Issues a commit against the current dbh.
8b445e33 507
8091aa91 508=cut
509
510sub txn_commit {
d79f59b9 511 my $self = shift;
512 if ($self->{transaction_depth} == 0) {
a32e8402 513 my $dbh = $self->dbh;
514 unless ($dbh->{AutoCommit}) {
4c248161 515 $self->debugobj->txn_commit()
986e4fca 516 if ($self->debug);
a32e8402 517 $dbh->commit;
986e4fca 518 }
8091aa91 519 }
520 else {
986e4fca 521 if (--$self->{transaction_depth} == 0) {
4c248161 522 $self->debugobj->txn_commit()
986e4fca 523 if ($self->debug);
524 $self->dbh->commit;
525 }
8091aa91 526 }
527}
528
529=head2 txn_rollback
530
181a28f4 531Issues a rollback against the current dbh. A nested rollback will
532throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
533which allows the rollback to propagate to the outermost transaction.
8b445e33 534
535=cut
536
8091aa91 537sub txn_rollback {
d79f59b9 538 my $self = shift;
a62cf8d4 539
540 eval {
541 if ($self->{transaction_depth} == 0) {
a32e8402 542 my $dbh = $self->dbh;
543 unless ($dbh->{AutoCommit}) {
4c248161 544 $self->debugobj->txn_rollback()
986e4fca 545 if ($self->debug);
a32e8402 546 $dbh->rollback;
986e4fca 547 }
a62cf8d4 548 }
549 else {
986e4fca 550 if (--$self->{transaction_depth} == 0) {
4c248161 551 $self->debugobj->txn_rollback()
986e4fca 552 if ($self->debug);
553 $self->dbh->rollback;
554 }
555 else {
1346e22d 556 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
986e4fca 557 }
a62cf8d4 558 }
559 };
560
561 if ($@) {
562 my $error = $@;
563 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
564 $error =~ /$exception_class/ and $self->throw_exception($error);
565 $self->{transaction_depth} = 0; # ensure that a failed rollback
566 $self->throw_exception($error); # resets the transaction depth
8091aa91 567 }
568}
8b445e33 569
223b8fe3 570sub _execute {
571 my ($self, $op, $extra_bind, $ident, @args) = @_;
572 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
944f30bf 573 unshift(@bind, @$extra_bind) if $extra_bind;
f59ffc79 574 if ($self->debug) {
e673f011 575 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
4c248161 576 $self->debugobj->query_start($sql, @debug_bind);
f59ffc79 577 }
75db246c 578 my $sth = eval { $self->sth($sql,$op) };
579
580 if (!$sth || $@) {
581 $self->throw_exception('no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql");
582 }
583
438adc0e 584 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
701da8c4 585 my $rv;
75d07914 586 if ($sth) {
4c248161 587 my $time = time();
95dad7e2 588 $rv = eval { $sth->execute(@bind) };
589
590 if ($@ || !$rv) {
591 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
592 }
75d07914 593 } else {
1c339d71 594 $self->throw_exception("'$sql' did not generate a statement.");
701da8c4 595 }
4c248161 596 if ($self->debug) {
597 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
598 $self->debugobj->query_end($sql, @debug_bind);
599 }
223b8fe3 600 return (wantarray ? ($rv, $sth, @bind) : $rv);
601}
602
8b445e33 603sub insert {
604 my ($self, $ident, $to_insert) = @_;
bc0c9800 605 $self->throw_exception(
606 "Couldn't insert ".join(', ',
607 map "$_ => $to_insert->{$_}", keys %$to_insert
608 )." into ${ident}"
609 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
8b445e33 610 return $to_insert;
611}
612
613sub update {
223b8fe3 614 return shift->_execute('update' => [], @_);
8b445e33 615}
616
617sub delete {
223b8fe3 618 return shift->_execute('delete' => [], @_);
8b445e33 619}
620
de705b51 621sub _select {
8b445e33 622 my ($self, $ident, $select, $condition, $attrs) = @_;
223b8fe3 623 my $order = $attrs->{order_by};
624 if (ref $condition eq 'SCALAR') {
625 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
626 }
8839560b 627 if (exists $attrs->{group_by} || $attrs->{having}) {
bc0c9800 628 $order = {
629 group_by => $attrs->{group_by},
630 having => $attrs->{having},
631 ($order ? (order_by => $order) : ())
632 };
54540863 633 }
5c91499f 634 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
9229f20a 635 if ($attrs->{software_limit} ||
636 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
637 $attrs->{software_limit} = 1;
5c91499f 638 } else {
0823196c 639 $self->throw_exception("rows attribute must be positive if present")
640 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
5c91499f 641 push @args, $attrs->{rows}, $attrs->{offset};
642 }
de705b51 643 return $self->_execute(@args);
644}
645
646sub select {
647 my $self = shift;
648 my ($ident, $select, $condition, $attrs) = @_;
cb5f2eea 649 return $self->cursor->new($self, \@_, $attrs);
8b445e33 650}
651
6157db4f 652# Need to call finish() to work round broken DBDs
653
1a14aa3f 654sub select_single {
de705b51 655 my $self = shift;
656 my ($rv, $sth, @bind) = $self->_select(@_);
6157db4f 657 my @row = $sth->fetchrow_array;
658 $sth->finish();
659 return @row;
1a14aa3f 660}
661
8b445e33 662sub sth {
cb5f2eea 663 my ($self, $sql) = @_;
91fa659e 664 # 3 is the if_active parameter which avoids active sth re-use
665 return $self->dbh->prepare_cached($sql, {}, 3);
8b445e33 666}
667
a953d8d9 668=head2 columns_info_for
669
670Returns database type info for a given table columns.
671
672=cut
673
674sub columns_info_for {
0d67fe74 675 my ($self, $table) = @_;
bfe10d87 676
a32e8402 677 my $dbh = $self->dbh;
678
679 if ($dbh->can('column_info')) {
a953d8d9 680 my %result;
a32e8402 681 my $old_raise_err = $dbh->{RaiseError};
682 my $old_print_err = $dbh->{PrintError};
683 $dbh->{RaiseError} = 1;
684 $dbh->{PrintError} = 0;
0d67fe74 685 eval {
4d272ce5 686 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
687 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
0d67fe74 688 $sth->execute();
689 while ( my $info = $sth->fetchrow_hashref() ){
bfe10d87 690 my %column_info;
0d67fe74 691 $column_info{data_type} = $info->{TYPE_NAME};
692 $column_info{size} = $info->{COLUMN_SIZE};
693 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
694 $column_info{default_value} = $info->{COLUMN_DEF};
695
696 $result{$info->{COLUMN_NAME}} = \%column_info;
697 }
698 };
a32e8402 699 $dbh->{RaiseError} = $old_raise_err;
700 $dbh->{PrintError} = $old_print_err;
0d67fe74 701 return \%result if !$@;
702 }
703
704 my %result;
a32e8402 705 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
0d67fe74 706 $sth->execute;
707 my @columns = @{$sth->{NAME_lc}};
708 for my $i ( 0 .. $#columns ){
709 my %column_info;
710 my $type_num = $sth->{TYPE}->[$i];
711 my $type_name;
a32e8402 712 if(defined $type_num && $dbh->can('type_info')) {
713 my $type_info = $dbh->type_info($type_num);
0d67fe74 714 $type_name = $type_info->{TYPE_NAME} if $type_info;
a953d8d9 715 }
0d67fe74 716 $column_info{data_type} = $type_name ? $type_name : $type_num;
717 $column_info{size} = $sth->{PRECISION}->[$i];
718 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
719
720 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
721 $column_info{data_type} = $1;
722 $column_info{size} = $2;
723 }
724
725 $result{$columns[$i]} = \%column_info;
726 }
bfe10d87 727
0d67fe74 728 return \%result;
a953d8d9 729}
730
843f8ecd 731sub last_insert_id {
732 my ($self, $row) = @_;
733
734 return $self->dbh->func('last_insert_rowid');
735
736}
737
90ec6cad 738sub sqlt_type { shift->dbh->{Driver}->{Name} }
1c339d71 739
e673f011 740sub create_ddl_dir
741{
742 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
743
744 if(!$dir || !-d $dir)
745 {
746 warn "No directory given, using ./\n";
747 $dir = "./";
748 }
749 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
750 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
751 $version ||= $schema->VERSION || '1.x';
752
1c339d71 753 eval "use SQL::Translator";
754 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
e673f011 755
756 my $sqlt = SQL::Translator->new({
757# debug => 1,
758 add_drop_table => 1,
759 });
760 foreach my $db (@$databases)
761 {
762 $sqlt->reset();
763 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
764# $sqlt->parser_args({'DBIx::Class' => $schema);
765 $sqlt->data($schema);
766 $sqlt->producer($db);
767
768 my $file;
769 my $filename = $schema->ddl_filename($db, $dir, $version);
770 if(-e $filename)
771 {
772 $self->throw_exception("$filename already exists, skipping $db");
773 next;
774 }
775 open($file, ">$filename")
776 or $self->throw_exception("Can't open $filename for writing ($!)");
777 my $output = $sqlt->translate;
778#use Data::Dumper;
779# print join(":", keys %{$schema->source_registrations});
780# print Dumper($sqlt->schema);
781 if(!$output)
782 {
783 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
784 next;
785 }
786 print $file $output;
787 close($file);
788 }
789
790}
791
792sub deployment_statements {
793 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
794 $type ||= $self->sqlt_type;
795 $version ||= $schema->VERSION || '1.x';
796 $dir ||= './';
0382d607 797 eval "use SQL::Translator";
798 if(!$@)
799 {
800 eval "use SQL::Translator::Parser::DBIx::Class;";
801 $self->throw_exception($@) if $@;
802 eval "use SQL::Translator::Producer::${type};";
803 $self->throw_exception($@) if $@;
804 my $tr = SQL::Translator->new(%$sqltargs);
805 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
806 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
807 }
e673f011 808
809 my $filename = $schema->ddl_filename($type, $dir, $version);
810 if(!-f $filename)
811 {
0382d607 812# $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
813 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
814 return;
e673f011 815 }
816 my $file;
817 open($file, "<$filename")
818 or $self->throw_exception("Can't open $filename ($!)");
819 my @rows = <$file>;
820 close($file);
821
822 return join('', @rows);
823
1c339d71 824}
843f8ecd 825
1c339d71 826sub deploy {
cb561d1a 827 my ($self, $schema, $type, $sqltargs) = @_;
e673f011 828 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, $sqltargs) ) {
e4fe9ba3 829 for ( split(";\n", $statement)) {
e673f011 830 next if($_ =~ /^--/);
831 next if(!$_);
832# next if($_ =~ /^DROP/m);
833 next if($_ =~ /^BEGIN TRANSACTION/m);
834 next if($_ =~ /^COMMIT/m);
4c248161 835 $self->debugobj->query_begin($_) if $self->debug;
e4fe9ba3 836 $self->dbh->do($_) or warn "SQL was:\n $_";
4c248161 837 $self->debugobj->query_end($_) if $self->debug;
e4fe9ba3 838 }
75d07914 839 }
1c339d71 840}
843f8ecd 841
92925617 842sub DESTROY { shift->disconnect }
843
8b445e33 8441;
845
92b858c9 846=head1 ENVIRONMENT VARIABLES
847
848=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
849
850If C<DBIX_CLASS_STORAGE_DBI_DEBUG> is set then SQL trace information
851is produced (as when the L<debug> method is set).
852
853If the value is of the form C<1=/path/name> then the trace output is
854written to the file C</path/name>.
855
d1cceec4 856This environment variable is checked when the storage object is first
857created (when you call connect on your schema). So, run-time changes
858to this environment variable will not take effect unless you also
859re-connect on your schema.
860
8b445e33 861=head1 AUTHORS
862
daec44b8 863Matt S. Trout <mst@shadowcatsystems.co.uk>
8b445e33 864
9f19b1d6 865Andy Grundman <andy@hybridized.org>
866
8b445e33 867=head1 LICENSE
868
869You may distribute this code under the same terms as Perl itself.
870
871=cut
872