Add pod for params of inflate/deflate coderefs
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Storage / DBI.pm
CommitLineData
8b445e33 1package DBIx::Class::Storage::DBI;
2
a62cf8d4 3use base 'DBIx::Class::Storage';
4
20a2c954 5use strict;
6use warnings;
8b445e33 7use DBI;
aeaf3ce2 8use SQL::Abstract::Limit;
28927b50 9use DBIx::Class::Storage::DBI::Cursor;
92b858c9 10use IO::File;
701da8c4 11use Carp::Clan qw/DBIx::Class/;
8b445e33 12
bd7efd39 13BEGIN {
14
cb5f2eea 15package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
bd7efd39 16
17use base qw/SQL::Abstract::Limit/;
18
54540863 19sub select {
20 my ($self, $table, $fields, $where, $order, @rest) = @_;
6346a152 21 $table = $self->_quote($table) unless ref($table);
54540863 22 @rest = (-1) unless defined $rest[0];
0823196c 23 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
24 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
8839560b 25 local $self->{having_bind} = [];
bc0c9800 26 my ($sql, @ret) = $self->SUPER::select(
27 $table, $self->_recurse_fields($fields), $where, $order, @rest
28 );
8839560b 29 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
54540863 30}
31
6346a152 32sub insert {
33 my $self = shift;
34 my $table = shift;
35 $table = $self->_quote($table) unless ref($table);
36 $self->SUPER::insert($table, @_);
37}
38
39sub update {
40 my $self = shift;
41 my $table = shift;
42 $table = $self->_quote($table) unless ref($table);
43 $self->SUPER::update($table, @_);
44}
45
46sub delete {
47 my $self = shift;
48 my $table = shift;
49 $table = $self->_quote($table) unless ref($table);
50 $self->SUPER::delete($table, @_);
51}
52
54540863 53sub _emulate_limit {
54 my $self = shift;
55 if ($_[3] == -1) {
56 return $_[1].$self->_order_by($_[2]);
57 } else {
58 return $self->SUPER::_emulate_limit(@_);
59 }
60}
61
62sub _recurse_fields {
63 my ($self, $fields) = @_;
64 my $ref = ref $fields;
65 return $self->_quote($fields) unless $ref;
66 return $$fields if $ref eq 'SCALAR';
67
68 if ($ref eq 'ARRAY') {
69 return join(', ', map { $self->_recurse_fields($_) } @$fields);
70 } elsif ($ref eq 'HASH') {
71 foreach my $func (keys %$fields) {
72 return $self->_sqlcase($func)
73 .'( '.$self->_recurse_fields($fields->{$func}).' )';
74 }
75 }
76}
77
78sub _order_by {
79 my $self = shift;
80 my $ret = '';
8839560b 81 my @extra;
54540863 82 if (ref $_[0] eq 'HASH') {
83 if (defined $_[0]->{group_by}) {
84 $ret = $self->_sqlcase(' group by ')
85 .$self->_recurse_fields($_[0]->{group_by});
86 }
8839560b 87 if (defined $_[0]->{having}) {
88 my $frag;
89 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
90 push(@{$self->{having_bind}}, @extra);
91 $ret .= $self->_sqlcase(' having ').$frag;
92 }
54540863 93 if (defined $_[0]->{order_by}) {
94 $ret .= $self->SUPER::_order_by($_[0]->{order_by});
95 }
e535069e 96 } elsif(ref $_[0] eq 'SCALAR') {
97 $ret = $self->_sqlcase(' order by ').${ $_[0] };
54540863 98 } else {
99 $ret = $self->SUPER::_order_by(@_);
100 }
101 return $ret;
102}
103
f48dd03f 104sub _order_directions {
105 my ($self, $order) = @_;
106 $order = $order->{order_by} if ref $order eq 'HASH';
107 return $self->SUPER::_order_directions($order);
108}
109
2a816814 110sub _table {
bd7efd39 111 my ($self, $from) = @_;
112 if (ref $from eq 'ARRAY') {
113 return $self->_recurse_from(@$from);
114 } elsif (ref $from eq 'HASH') {
115 return $self->_make_as($from);
116 } else {
6346a152 117 return $from; # would love to quote here but _table ends up getting called
118 # twice during an ->select without a limit clause due to
119 # the way S::A::Limit->select works. should maybe consider
120 # bypassing this and doing S::A::select($self, ...) in
121 # our select method above. meantime, quoting shims have
122 # been added to select/insert/update/delete here
bd7efd39 123 }
124}
125
126sub _recurse_from {
127 my ($self, $from, @join) = @_;
128 my @sqlf;
129 push(@sqlf, $self->_make_as($from));
130 foreach my $j (@join) {
131 my ($to, $on) = @$j;
73856587 132
54540863 133 # check whether a join type exists
134 my $join_clause = '';
135 if (ref($to) eq 'HASH' and exists($to->{-join_type})) {
136 $join_clause = ' '.uc($to->{-join_type}).' JOIN ';
137 } else {
138 $join_clause = ' JOIN ';
139 }
73856587 140 push(@sqlf, $join_clause);
141
bd7efd39 142 if (ref $to eq 'ARRAY') {
143 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
144 } else {
96cdbbab 145 push(@sqlf, $self->_make_as($to));
bd7efd39 146 }
147 push(@sqlf, ' ON ', $self->_join_condition($on));
148 }
149 return join('', @sqlf);
150}
151
152sub _make_as {
153 my ($self, $from) = @_;
54540863 154 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
bc0c9800 155 reverse each %{$self->_skip_options($from)});
73856587 156}
157
158sub _skip_options {
54540863 159 my ($self, $hash) = @_;
160 my $clean_hash = {};
161 $clean_hash->{$_} = $hash->{$_}
162 for grep {!/^-/} keys %$hash;
163 return $clean_hash;
bd7efd39 164}
165
166sub _join_condition {
167 my ($self, $cond) = @_;
5efe4c79 168 if (ref $cond eq 'HASH') {
169 my %j;
bc0c9800 170 for (keys %$cond) {
171 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
172 };
5efe4c79 173 return $self->_recurse_where(\%j);
174 } elsif (ref $cond eq 'ARRAY') {
175 return join(' OR ', map { $self->_join_condition($_) } @$cond);
176 } else {
177 die "Can't handle this yet!";
178 }
bd7efd39 179}
180
2a816814 181sub _quote {
182 my ($self, $label) = @_;
183 return '' unless defined $label;
3b24f6ea 184 return "*" if $label eq '*';
41728a6e 185 return $label unless $self->{quote_char};
3b24f6ea 186 if(ref $self->{quote_char} eq "ARRAY"){
187 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
188 if !defined $self->{name_sep};
189 my $sep = $self->{name_sep};
190 return join($self->{name_sep},
191 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
192 split(/\Q$sep\E/,$label));
193 }
2a816814 194 return $self->SUPER::_quote($label);
195}
196
f66596f9 197sub _RowNum {
198 my $self = shift;
199 my $c;
200 $_[0] =~ s/SELECT (.*?) FROM/
201 'SELECT '.join(', ', map { $_.' AS col'.++$c } split(', ', $1)).' FROM'/e;
202 $self->SUPER::_RowNum(@_);
203}
204
7be93b07 205# Accessor for setting limit dialect. This is useful
206# for JDBC-bridge among others where the remote SQL-dialect cannot
207# be determined by the name of the driver alone.
208#
209sub limit_dialect {
210 my $self = shift;
211 $self->{limit_dialect} = shift if @_;
212 return $self->{limit_dialect};
213}
214
2437a1e3 215sub quote_char {
216 my $self = shift;
217 $self->{quote_char} = shift if @_;
218 return $self->{quote_char};
219}
220
221sub name_sep {
222 my $self = shift;
223 $self->{name_sep} = shift if @_;
224 return $self->{name_sep};
225}
226
227
228
229
486ad69b 230package DBIx::Class::Storage::DBI::DebugCallback;
231
232sub print {
233 my ($self, $string) = @_;
234 $string =~ m/^(\w+)/;
235 ${$self}->($1, $string);
236}
237
bd7efd39 238} # End of BEGIN block
239
8b445e33 240use base qw/DBIx::Class/;
241
1f692767 242__PACKAGE__->load_components(qw/AccessorGroup/);
8b445e33 243
223b8fe3 244__PACKAGE__->mk_group_accessors('simple' =>
1346e22d 245 qw/connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugfh
246 cursor on_connect_do transaction_depth/);
8091aa91 247
8b445e33 248sub new {
223b8fe3 249 my $new = bless({}, ref $_[0] || $_[0]);
28927b50 250 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
d79f59b9 251 $new->transaction_depth(0);
5e65c358 252 if (defined($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}) &&
253 ($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} =~ /=(.+)$/)) {
bc0c9800 254 $new->debugfh(IO::File->new($1, 'w'))
255 or $new->throw_exception("Cannot open trace file $1");
92b858c9 256 } else {
257 $new->debugfh(IO::File->new('>&STDERR'));
258 }
28927b50 259 $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG};
223b8fe3 260 return $new;
8b445e33 261}
262
1c339d71 263sub throw_exception {
264 my ($self, $msg) = @_;
3b042bcb 265 croak($msg);
1c339d71 266}
267
75d07914 268=head1 NAME
8b445e33 269
270DBIx::Class::Storage::DBI - DBI storage handler
271
272=head1 SYNOPSIS
273
274=head1 DESCRIPTION
275
276This class represents the connection to the database
277
278=head1 METHODS
279
8b445e33 280=cut
281
d7c4c15c 282=head2 on_connect_do
283
284Executes the sql statements given as a listref on every db connect.
285
92b858c9 286=head2 debug
287
288Causes SQL trace information to be emitted on C<debugfh> filehandle
289(or C<STDERR> if C<debugfh> has not specifically been set).
290
291=head2 debugfh
292
293Sets or retrieves the filehandle used for trace/debug output. This
294should be an IO::Handle compatible object (only the C<print> method is
295used). Initially set to be STDERR - although see information on the
296L<DBIX_CLASS_STORAGE_DBI_DEBUG> environment variable.
297
486ad69b 298=head2 debugcb
299
300Sets a callback to be executed each time a statement is run; takes a sub
301reference. Overrides debugfh. Callback is executed as $sub->($op, $info)
302where $op is SELECT/INSERT/UPDATE/DELETE and $info is what would normally
303be printed.
304
d7c4c15c 305=cut
306
486ad69b 307sub debugcb {
308 my ($self, $cb) = @_;
309 my $cb_obj = bless(\$cb, 'DBIx::Class::Storage::DBI::DebugCallback');
310 $self->debugfh($cb_obj);
311}
312
412db1f4 313sub disconnect {
314 my ($self) = @_;
315
92925617 316 if( $self->connected ) {
317 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
318 $self->_dbh->disconnect;
319 $self->_dbh(undef);
320 }
412db1f4 321}
322
323sub connected {
8b445e33 324 my ($self) = @_;
412db1f4 325
1346e22d 326 if(my $dbh = $self->_dbh) {
327 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
328 $self->_sql_maker(undef);
329 return $self->_dbh(undef);
330 }
331 elsif($self->_conn_pid != $$) {
332 $self->_dbh->{InactiveDestroy} = 1;
333 $self->_sql_maker(undef);
334 return $self->_dbh(undef)
335 }
336 return ($dbh->FETCH('Active') && $dbh->ping);
337 }
338
339 return 0;
412db1f4 340}
341
342sub ensure_connected {
343 my ($self) = @_;
344
345 unless ($self->connected) {
8b445e33 346 $self->_populate_dbh;
347 }
412db1f4 348}
349
c235bbae 350=head2 dbh
351
352Returns the dbh - a data base handle of class L<DBI>.
353
354=cut
355
412db1f4 356sub dbh {
357 my ($self) = @_;
358
359 $self->ensure_connected;
8b445e33 360 return $self->_dbh;
361}
362
48c69e7c 363sub sql_maker {
364 my ($self) = @_;
fdc1c3d0 365 unless ($self->_sql_maker) {
bd7efd39 366 $self->_sql_maker(new DBIC::SQL::Abstract( limit_dialect => $self->dbh ));
48c69e7c 367 }
368 return $self->_sql_maker;
369}
370
8b445e33 371sub _populate_dbh {
372 my ($self) = @_;
373 my @info = @{$self->connect_info || []};
374 $self->_dbh($self->_connect(@info));
843f8ecd 375 my $driver = $self->_dbh->{Driver}->{Name};
34470972 376 eval "require DBIx::Class::Storage::DBI::${driver}";
377 unless ($@) {
843f8ecd 378 bless $self, "DBIx::Class::Storage::DBI::${driver}";
379 }
d7c4c15c 380 # if on-connect sql statements are given execute them
381 foreach my $sql_statement (@{$self->on_connect_do || []}) {
382 $self->_dbh->do($sql_statement);
383 }
5ef3e508 384
1346e22d 385 $self->_conn_pid($$);
386 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
8b445e33 387}
388
389sub _connect {
390 my ($self, @info) = @_;
5ef3e508 391
9d31f7dc 392 $self->throw_exception("You failed to provide any connection info")
393 if !@info;
394
90ec6cad 395 my ($old_connect_via, $dbh);
396
5ef3e508 397 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
90ec6cad 398 $old_connect_via = $DBI::connect_via;
5ef3e508 399 $DBI::connect_via = 'connect';
5ef3e508 400 }
401
75db246c 402 eval {
403 if(ref $info[0] eq 'CODE') {
404 $dbh = &{$info[0]};
405 }
406 else {
407 $dbh = DBI->connect(@info);
408 }
409 };
90ec6cad 410
411 $DBI::connect_via = $old_connect_via if $old_connect_via;
412
75db246c 413 if (!$dbh || $@) {
414 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
415 }
90ec6cad 416
e571e823 417 $dbh;
8b445e33 418}
419
8091aa91 420=head2 txn_begin
8b445e33 421
8091aa91 422Calls begin_work on the current dbh.
8b445e33 423
181a28f4 424See L<DBIx::Class::Schema> for the txn_do() method, which allows for
425an entire code block to be executed transactionally.
426
8b445e33 427=cut
428
8091aa91 429sub txn_begin {
d79f59b9 430 my $self = shift;
a32e8402 431 if ($self->{transaction_depth}++ == 0) {
432 my $dbh = $self->dbh;
433 if ($dbh->{AutoCommit}) {
434 $self->debugfh->print("BEGIN WORK\n")
435 if ($self->debug);
436 $dbh->begin_work;
437 }
986e4fca 438 }
8091aa91 439}
8b445e33 440
8091aa91 441=head2 txn_commit
8b445e33 442
8091aa91 443Issues a commit against the current dbh.
8b445e33 444
8091aa91 445=cut
446
447sub txn_commit {
d79f59b9 448 my $self = shift;
449 if ($self->{transaction_depth} == 0) {
a32e8402 450 my $dbh = $self->dbh;
451 unless ($dbh->{AutoCommit}) {
986e4fca 452 $self->debugfh->print("COMMIT\n")
453 if ($self->debug);
a32e8402 454 $dbh->commit;
986e4fca 455 }
8091aa91 456 }
457 else {
986e4fca 458 if (--$self->{transaction_depth} == 0) {
459 $self->debugfh->print("COMMIT\n")
460 if ($self->debug);
461 $self->dbh->commit;
462 }
8091aa91 463 }
464}
465
466=head2 txn_rollback
467
181a28f4 468Issues a rollback against the current dbh. A nested rollback will
469throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
470which allows the rollback to propagate to the outermost transaction.
8b445e33 471
472=cut
473
8091aa91 474sub txn_rollback {
d79f59b9 475 my $self = shift;
a62cf8d4 476
477 eval {
478 if ($self->{transaction_depth} == 0) {
a32e8402 479 my $dbh = $self->dbh;
480 unless ($dbh->{AutoCommit}) {
986e4fca 481 $self->debugfh->print("ROLLBACK\n")
482 if ($self->debug);
a32e8402 483 $dbh->rollback;
986e4fca 484 }
a62cf8d4 485 }
486 else {
986e4fca 487 if (--$self->{transaction_depth} == 0) {
488 $self->debugfh->print("ROLLBACK\n")
489 if ($self->debug);
490 $self->dbh->rollback;
491 }
492 else {
1346e22d 493 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
986e4fca 494 }
a62cf8d4 495 }
496 };
497
498 if ($@) {
499 my $error = $@;
500 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
501 $error =~ /$exception_class/ and $self->throw_exception($error);
502 $self->{transaction_depth} = 0; # ensure that a failed rollback
503 $self->throw_exception($error); # resets the transaction depth
8091aa91 504 }
505}
8b445e33 506
223b8fe3 507sub _execute {
508 my ($self, $op, $extra_bind, $ident, @args) = @_;
509 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
944f30bf 510 unshift(@bind, @$extra_bind) if $extra_bind;
f59ffc79 511 if ($self->debug) {
181a28f4 512 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
513 $self->debugfh->print("$sql: " . join(', ', @debug_bind) . "\n");
f59ffc79 514 }
75db246c 515 my $sth = eval { $self->sth($sql,$op) };
516
517 if (!$sth || $@) {
518 $self->throw_exception('no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql");
519 }
520
438adc0e 521 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
701da8c4 522 my $rv;
75d07914 523 if ($sth) {
95dad7e2 524 $rv = eval { $sth->execute(@bind) };
525
526 if ($@ || !$rv) {
527 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
528 }
75d07914 529 } else {
1c339d71 530 $self->throw_exception("'$sql' did not generate a statement.");
701da8c4 531 }
223b8fe3 532 return (wantarray ? ($rv, $sth, @bind) : $rv);
533}
534
8b445e33 535sub insert {
536 my ($self, $ident, $to_insert) = @_;
bc0c9800 537 $self->throw_exception(
538 "Couldn't insert ".join(', ',
539 map "$_ => $to_insert->{$_}", keys %$to_insert
540 )." into ${ident}"
541 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
8b445e33 542 return $to_insert;
543}
544
545sub update {
223b8fe3 546 return shift->_execute('update' => [], @_);
8b445e33 547}
548
549sub delete {
223b8fe3 550 return shift->_execute('delete' => [], @_);
8b445e33 551}
552
de705b51 553sub _select {
8b445e33 554 my ($self, $ident, $select, $condition, $attrs) = @_;
223b8fe3 555 my $order = $attrs->{order_by};
556 if (ref $condition eq 'SCALAR') {
557 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
558 }
8839560b 559 if (exists $attrs->{group_by} || $attrs->{having}) {
bc0c9800 560 $order = {
561 group_by => $attrs->{group_by},
562 having => $attrs->{having},
563 ($order ? (order_by => $order) : ())
564 };
54540863 565 }
5c91499f 566 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
9229f20a 567 if ($attrs->{software_limit} ||
568 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
569 $attrs->{software_limit} = 1;
5c91499f 570 } else {
0823196c 571 $self->throw_exception("rows attribute must be positive if present")
572 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
5c91499f 573 push @args, $attrs->{rows}, $attrs->{offset};
574 }
de705b51 575 return $self->_execute(@args);
576}
577
578sub select {
579 my $self = shift;
580 my ($ident, $select, $condition, $attrs) = @_;
cb5f2eea 581 return $self->cursor->new($self, \@_, $attrs);
8b445e33 582}
583
6157db4f 584# Need to call finish() to work round broken DBDs
585
1a14aa3f 586sub select_single {
de705b51 587 my $self = shift;
588 my ($rv, $sth, @bind) = $self->_select(@_);
6157db4f 589 my @row = $sth->fetchrow_array;
590 $sth->finish();
591 return @row;
1a14aa3f 592}
593
8b445e33 594sub sth {
cb5f2eea 595 my ($self, $sql) = @_;
91fa659e 596 # 3 is the if_active parameter which avoids active sth re-use
597 return $self->dbh->prepare_cached($sql, {}, 3);
8b445e33 598}
599
a953d8d9 600=head2 columns_info_for
601
602Returns database type info for a given table columns.
603
604=cut
605
606sub columns_info_for {
0d67fe74 607 my ($self, $table) = @_;
bfe10d87 608
a32e8402 609 my $dbh = $self->dbh;
610
611 if ($dbh->can('column_info')) {
a953d8d9 612 my %result;
a32e8402 613 my $old_raise_err = $dbh->{RaiseError};
614 my $old_print_err = $dbh->{PrintError};
615 $dbh->{RaiseError} = 1;
616 $dbh->{PrintError} = 0;
0d67fe74 617 eval {
a32e8402 618 my $sth = $dbh->column_info( undef, undef, $table, '%' );
0d67fe74 619 $sth->execute();
620 while ( my $info = $sth->fetchrow_hashref() ){
bfe10d87 621 my %column_info;
0d67fe74 622 $column_info{data_type} = $info->{TYPE_NAME};
623 $column_info{size} = $info->{COLUMN_SIZE};
624 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
625 $column_info{default_value} = $info->{COLUMN_DEF};
626
627 $result{$info->{COLUMN_NAME}} = \%column_info;
628 }
629 };
a32e8402 630 $dbh->{RaiseError} = $old_raise_err;
631 $dbh->{PrintError} = $old_print_err;
0d67fe74 632 return \%result if !$@;
633 }
634
635 my %result;
a32e8402 636 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
0d67fe74 637 $sth->execute;
638 my @columns = @{$sth->{NAME_lc}};
639 for my $i ( 0 .. $#columns ){
640 my %column_info;
641 my $type_num = $sth->{TYPE}->[$i];
642 my $type_name;
a32e8402 643 if(defined $type_num && $dbh->can('type_info')) {
644 my $type_info = $dbh->type_info($type_num);
0d67fe74 645 $type_name = $type_info->{TYPE_NAME} if $type_info;
a953d8d9 646 }
0d67fe74 647 $column_info{data_type} = $type_name ? $type_name : $type_num;
648 $column_info{size} = $sth->{PRECISION}->[$i];
649 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
650
651 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
652 $column_info{data_type} = $1;
653 $column_info{size} = $2;
654 }
655
656 $result{$columns[$i]} = \%column_info;
657 }
bfe10d87 658
0d67fe74 659 return \%result;
a953d8d9 660}
661
843f8ecd 662sub last_insert_id {
663 my ($self, $row) = @_;
664
665 return $self->dbh->func('last_insert_rowid');
666
667}
668
90ec6cad 669sub sqlt_type { shift->dbh->{Driver}->{Name} }
1c339d71 670
671sub deployment_statements {
cb561d1a 672 my ($self, $schema, $type, $sqltargs) = @_;
1c339d71 673 $type ||= $self->sqlt_type;
674 eval "use SQL::Translator";
675 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
676 eval "use SQL::Translator::Parser::DBIx::Class;";
75d07914 677 $self->throw_exception($@) if $@;
1c339d71 678 eval "use SQL::Translator::Producer::${type};";
679 $self->throw_exception($@) if $@;
cb561d1a 680 my $tr = SQL::Translator->new(%$sqltargs);
1c339d71 681 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
682 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
683}
843f8ecd 684
1c339d71 685sub deploy {
cb561d1a 686 my ($self, $schema, $type, $sqltargs) = @_;
e4fe9ba3 687 foreach my $statement ( $self->deployment_statements($schema, $type, $sqltargs) ) {
688 for ( split(";\n", $statement)) {
689 $self->debugfh->print("$_\n") if $self->debug;
690 $self->dbh->do($_) or warn "SQL was:\n $_";
691 }
75d07914 692 }
1c339d71 693}
843f8ecd 694
92925617 695sub DESTROY { shift->disconnect }
696
8b445e33 6971;
698
92b858c9 699=head1 ENVIRONMENT VARIABLES
700
701=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
702
703If C<DBIX_CLASS_STORAGE_DBI_DEBUG> is set then SQL trace information
704is produced (as when the L<debug> method is set).
705
706If the value is of the form C<1=/path/name> then the trace output is
707written to the file C</path/name>.
708
d1cceec4 709This environment variable is checked when the storage object is first
710created (when you call connect on your schema). So, run-time changes
711to this environment variable will not take effect unless you also
712re-connect on your schema.
713
8b445e33 714=head1 AUTHORS
715
daec44b8 716Matt S. Trout <mst@shadowcatsystems.co.uk>
8b445e33 717
9f19b1d6 718Andy Grundman <andy@hybridized.org>
719
8b445e33 720=head1 LICENSE
721
722You may distribute this code under the same terms as Perl itself.
723
724=cut
725