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