1 package DBIx::Class::Storage::DBI;
2 # -*- mode: cperl; cperl-indent-level: 2 -*-
4 use base 'DBIx::Class::Storage';
9 use SQL::Abstract::Limit;
10 use DBIx::Class::Storage::DBI::Cursor;
11 use DBIx::Class::Storage::Statistics;
12 use Scalar::Util qw/blessed weaken/;
14 __PACKAGE__->mk_group_accessors('simple' =>
15 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
16 _conn_pid _conn_tid disable_sth_caching on_connect_do
17 on_disconnect_do transaction_depth unsafe _dbh_autocommit
18 auto_savepoint savepoints/
21 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
23 __PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
24 __PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
28 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
30 use base qw/SQL::Abstract::Limit/;
32 # This prevents the caching of $dbh in S::A::L, I believe
34 my $self = shift->SUPER::new(@_);
36 # If limit_dialect is a ref (like a $dbh), go ahead and replace
37 # it with what it resolves to:
38 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
39 if ref $self->{limit_dialect};
45 my ($self, $sql, $order, $rows, $offset ) = @_;
48 my $last = $rows + $offset;
49 my ( $order_by ) = $self->_order_by( $order );
54 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
59 WHERE ROW_NUM BETWEEN $offset AND $last
65 # While we're at it, this should make LIMIT queries more efficient,
66 # without digging into things too deeply
67 use Scalar::Util 'blessed';
69 my ($self, $syntax) = @_;
70 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
71 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
72 return 'RowNumberOver';
75 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
79 my ($self, $table, $fields, $where, $order, @rest) = @_;
80 $table = $self->_quote($table) unless ref($table);
81 local $self->{rownum_hack_count} = 1
82 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
83 @rest = (-1) unless defined $rest[0];
84 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
85 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
86 local $self->{having_bind} = [];
87 my ($sql, @ret) = $self->SUPER::select(
88 $table, $self->_recurse_fields($fields), $where, $order, @rest
93 $self->{for} eq 'update' ? ' FOR UPDATE' :
94 $self->{for} eq 'shared' ? ' FOR SHARE' :
99 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
105 $table = $self->_quote($table) unless ref($table);
106 $self->SUPER::insert($table, @_);
112 $table = $self->_quote($table) unless ref($table);
113 $self->SUPER::update($table, @_);
119 $table = $self->_quote($table) unless ref($table);
120 $self->SUPER::delete($table, @_);
126 return $_[1].$self->_order_by($_[2]);
128 return $self->SUPER::_emulate_limit(@_);
132 sub _recurse_fields {
133 my ($self, $fields, $params) = @_;
134 my $ref = ref $fields;
135 return $self->_quote($fields) unless $ref;
136 return $$fields if $ref eq 'SCALAR';
138 if ($ref eq 'ARRAY') {
139 return join(', ', map {
140 $self->_recurse_fields($_)
141 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
142 ? ' AS col'.$self->{rownum_hack_count}++
145 } elsif ($ref eq 'HASH') {
146 foreach my $func (keys %$fields) {
147 return $self->_sqlcase($func)
148 .'( '.$self->_recurse_fields($fields->{$func}).' )';
157 if (ref $_[0] eq 'HASH') {
158 if (defined $_[0]->{group_by}) {
159 $ret = $self->_sqlcase(' group by ')
160 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
162 if (defined $_[0]->{having}) {
164 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
165 push(@{$self->{having_bind}}, @extra);
166 $ret .= $self->_sqlcase(' having ').$frag;
168 if (defined $_[0]->{order_by}) {
169 $ret .= $self->_order_by($_[0]->{order_by});
171 } elsif (ref $_[0] eq 'SCALAR') {
172 $ret = $self->_sqlcase(' order by ').${ $_[0] };
173 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
174 my @order = @{+shift};
175 $ret = $self->_sqlcase(' order by ')
177 my $r = $self->_order_by($_, @_);
178 $r =~ s/^ ?ORDER BY //i;
182 $ret = $self->SUPER::_order_by(@_);
187 sub _order_directions {
188 my ($self, $order) = @_;
189 $order = $order->{order_by} if ref $order eq 'HASH';
190 return $self->SUPER::_order_directions($order);
194 my ($self, $from) = @_;
195 if (ref $from eq 'ARRAY') {
196 return $self->_recurse_from(@$from);
197 } elsif (ref $from eq 'HASH') {
198 return $self->_make_as($from);
200 return $from; # would love to quote here but _table ends up getting called
201 # twice during an ->select without a limit clause due to
202 # the way S::A::Limit->select works. should maybe consider
203 # bypassing this and doing S::A::select($self, ...) in
204 # our select method above. meantime, quoting shims have
205 # been added to select/insert/update/delete here
210 my ($self, $from, @join) = @_;
212 push(@sqlf, $self->_make_as($from));
213 foreach my $j (@join) {
216 # check whether a join type exists
217 my $join_clause = '';
218 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
219 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
220 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
222 $join_clause = ' JOIN ';
224 push(@sqlf, $join_clause);
226 if (ref $to eq 'ARRAY') {
227 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
229 push(@sqlf, $self->_make_as($to));
231 push(@sqlf, ' ON ', $self->_join_condition($on));
233 return join('', @sqlf);
237 my ($self, $from) = @_;
238 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
239 reverse each %{$self->_skip_options($from)});
243 my ($self, $hash) = @_;
245 $clean_hash->{$_} = $hash->{$_}
246 for grep {!/^-/} keys %$hash;
250 sub _join_condition {
251 my ($self, $cond) = @_;
252 if (ref $cond eq 'HASH') {
257 # XXX no throw_exception() in this package and croak() fails with strange results
258 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
259 if ref($v) ne 'SCALAR';
263 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
266 return scalar($self->_recurse_where(\%j));
267 } elsif (ref $cond eq 'ARRAY') {
268 return join(' OR ', map { $self->_join_condition($_) } @$cond);
270 die "Can't handle this yet!";
275 my ($self, $label) = @_;
276 return '' unless defined $label;
277 return "*" if $label eq '*';
278 return $label unless $self->{quote_char};
279 if(ref $self->{quote_char} eq "ARRAY"){
280 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
281 if !defined $self->{name_sep};
282 my $sep = $self->{name_sep};
283 return join($self->{name_sep},
284 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
285 split(/\Q$sep\E/,$label));
287 return $self->SUPER::_quote($label);
292 $self->{limit_dialect} = shift if @_;
293 return $self->{limit_dialect};
298 $self->{quote_char} = shift if @_;
299 return $self->{quote_char};
304 $self->{name_sep} = shift if @_;
305 return $self->{name_sep};
308 } # End of BEGIN block
312 DBIx::Class::Storage::DBI - DBI storage handler
318 This class represents the connection to an RDBMS via L<DBI>. See
319 L<DBIx::Class::Storage> for general information. This pod only
320 documents DBI-specific methods and behaviors.
327 my $new = shift->next::method(@_);
329 $new->transaction_depth(0);
330 $new->_sql_maker_opts({});
331 $new->{savepoints} = [];
332 $new->{_in_dbh_do} = 0;
333 $new->{_dbh_gen} = 0;
340 The arguments of C<connect_info> are always a single array reference.
342 This is normally accessed via L<DBIx::Class::Schema/connection>, which
343 encapsulates its argument list in an arrayref before calling
344 C<connect_info> here.
346 The arrayref can either contain the same set of arguments one would
347 normally pass to L<DBI/connect>, or a lone code reference which returns
348 a connected database handle. Please note that the L<DBI> docs
349 recommend that you always explicitly set C<AutoCommit> to either
350 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
351 to C<1>, and that you perform transactions via our L</txn_do>
352 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
353 set it to zero. This is the default for most DBDs. See below for more
356 In either case, if the final argument in your connect_info happens
357 to be a hashref, C<connect_info> will look there for several
358 connection-specific options:
364 Specifies things to do immediately after connecting or re-connecting to
365 the database. Its value may contain:
369 =item an array reference
371 This contains SQL statements to execute in order. Each element contains
372 a string or a code reference that returns a string.
374 =item a code reference
376 This contains some code to execute. Unlike code references within an
377 array reference, its return value is ignored.
381 =item on_disconnect_do
383 Takes arguments in the same form as L<on_connect_do> and executes them
384 immediately before disconnecting from the database.
386 Note, this only runs if you explicitly call L<disconnect> on the
389 =item disable_sth_caching
391 If set to a true value, this option will disable the caching of
392 statement handles via L<DBI/prepare_cached>.
396 Sets the limit dialect. This is useful for JDBC-bridge among others
397 where the remote SQL-dialect cannot be determined by the name of the
402 Specifies what characters to use to quote table and column names. If
403 you use this you will want to specify L<name_sep> as well.
405 quote_char expects either a single character, in which case is it is placed
406 on either side of the table/column, or an arrayref of length 2 in which case the
407 table/column name is placed between the elements.
409 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
410 use C<quote_char =E<gt> [qw/[ ]/]>.
414 This only needs to be used in conjunction with L<quote_char>, and is used to
415 specify the charecter that seperates elements (schemas, tables, columns) from
416 each other. In most cases this is simply a C<.>.
420 This Storage driver normally installs its own C<HandleError>, sets
421 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
422 all database handles, including those supplied by a coderef. It does this
423 so that it can have consistent and useful error behavior.
425 If you set this option to a true value, Storage will not do its usual
426 modifications to the database handle's attributes, and instead relies on
427 the settings in your connect_info DBI options (or the values you set in
428 your connection coderef, in the case that you are connecting via coderef).
430 Note that your custom settings can cause Storage to malfunction,
431 especially if you set a C<HandleError> handler that suppresses exceptions
432 and/or disable C<RaiseError>.
436 If this option is true, L<DBIx::Class> will use savepoints when nesting
437 transactions, making it possible to recover from failure in the inner
438 transaction without having to abort all outer transactions.
442 These options can be mixed in with your other L<DBI> connection attributes,
443 or placed in a seperate hashref after all other normal L<DBI> connection
446 Every time C<connect_info> is invoked, any previous settings for
447 these options will be cleared before setting the new ones, regardless of
448 whether any options are specified in the new C<connect_info>.
450 Another Important Note:
452 DBIC can do some wonderful magic with handling exceptions,
453 disconnections, and transactions when you use C<< AutoCommit => 1 >>
454 combined with C<txn_do> for transaction support.
456 If you set C<< AutoCommit => 0 >> in your connect info, then you are always
457 in an assumed transaction between commits, and you're telling us you'd
458 like to manage that manually. A lot of DBIC's magic protections
459 go away. We can't protect you from exceptions due to database
460 disconnects because we don't know anything about how to restart your
461 transactions. You're on your own for handling all sorts of exceptional
462 cases if you choose the C<< AutoCommit => 0 >> path, just as you would
467 # Simple SQLite connection
468 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
471 ->connect_info([ sub { DBI->connect(...) } ]);
473 # A bit more complicated
480 { quote_char => q{"}, name_sep => q{.} },
484 # Equivalent to the previous example
490 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
494 # Subref + DBIC-specific connection options
497 sub { DBI->connect(...) },
501 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
502 disable_sth_caching => 1,
510 my ($self, $info_arg) = @_;
512 return $self->_connect_info if !$info_arg;
514 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
515 # the new set of options
516 $self->_sql_maker(undef);
517 $self->_sql_maker_opts({});
518 $self->_connect_info([@$info_arg]); # copy for _connect_info
520 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
522 my $last_info = $dbi_info->[-1];
523 if(ref $last_info eq 'HASH') {
524 $last_info = { %$last_info }; # so delete is non-destructive
525 my @storage_option = qw(
526 on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
529 for my $storage_opt (@storage_option) {
530 if(my $value = delete $last_info->{$storage_opt}) {
531 $self->$storage_opt($value);
534 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
535 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
536 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
539 # re-insert modified hashref
540 $dbi_info->[-1] = $last_info;
542 # Get rid of any trailing empty hashref
543 pop(@$dbi_info) if !keys %$last_info;
545 $self->_dbi_connect_info($dbi_info);
547 $self->_connect_info;
552 This method is deprecated in favor of setting via L</connect_info>.
556 Arguments: ($subref | $method_name), @extra_coderef_args?
558 Execute the given $subref or $method_name using the new exception-based
559 connection management.
561 The first two arguments will be the storage object that C<dbh_do> was called
562 on and a database handle to use. Any additional arguments will be passed
563 verbatim to the called subref as arguments 2 and onwards.
565 Using this (instead of $self->_dbh or $self->dbh) ensures correct
566 exception handling and reconnection (or failover in future subclasses).
568 Your subref should have no side-effects outside of the database, as
569 there is the potential for your subref to be partially double-executed
570 if the database connection was stale/dysfunctional.
574 my @stuff = $schema->storage->dbh_do(
576 my ($storage, $dbh, @cols) = @_;
577 my $cols = join(q{, }, @cols);
578 $dbh->selectrow_array("SELECT $cols FROM foo");
589 my $dbh = $self->_dbh;
591 return $self->$code($dbh, @_) if $self->{_in_dbh_do}
592 || $self->{transaction_depth};
594 local $self->{_in_dbh_do} = 1;
597 my $want_array = wantarray;
600 $self->_verify_pid if $dbh;
602 $self->_populate_dbh;
607 @result = $self->$code($dbh, @_);
609 elsif(defined $want_array) {
610 $result[0] = $self->$code($dbh, @_);
613 $self->$code($dbh, @_);
618 if(!$exception) { return $want_array ? @result : $result[0] }
620 $self->throw_exception($exception) if $self->connected;
622 # We were not connected - reconnect and retry, but let any
623 # exception fall right through this time
624 $self->_populate_dbh;
625 $self->$code($self->_dbh, @_);
628 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
629 # It also informs dbh_do to bypass itself while under the direction of txn_do,
630 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
635 ref $coderef eq 'CODE' or $self->throw_exception
636 ('$coderef must be a CODE reference');
638 return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
640 local $self->{_in_dbh_do} = 1;
643 my $want_array = wantarray;
648 $self->_verify_pid if $self->_dbh;
649 $self->_populate_dbh if !$self->_dbh;
653 @result = $coderef->(@_);
655 elsif(defined $want_array) {
656 $result[0] = $coderef->(@_);
665 if(!$exception) { return $want_array ? @result : $result[0] }
667 if($tried++ > 0 || $self->connected) {
668 eval { $self->txn_rollback };
669 my $rollback_exception = $@;
670 if($rollback_exception) {
671 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
672 $self->throw_exception($exception) # propagate nested rollback
673 if $rollback_exception =~ /$exception_class/;
675 $self->throw_exception(
676 "Transaction aborted: ${exception}. "
677 . "Rollback failed: ${rollback_exception}"
680 $self->throw_exception($exception)
683 # We were not connected, and was first try - reconnect and retry
685 $self->_populate_dbh;
691 Our C<disconnect> method also performs a rollback first if the
692 database is not in C<AutoCommit> mode.
699 if( $self->connected ) {
700 my $connection_do = $self->on_disconnect_do;
701 $self->_do_connection_actions($connection_do) if ref($connection_do);
703 $self->_dbh->rollback unless $self->_dbh_autocommit;
704 $self->_dbh->disconnect;
713 if(my $dbh = $self->_dbh) {
714 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
721 return 0 if !$self->_dbh;
723 return ($dbh->FETCH('Active') && $dbh->ping);
729 # handle pid changes correctly
730 # NOTE: assumes $self->_dbh is a valid $dbh
734 return if defined $self->_conn_pid && $self->_conn_pid == $$;
736 $self->_dbh->{InactiveDestroy} = 1;
743 sub ensure_connected {
746 unless ($self->connected) {
747 $self->_populate_dbh;
753 Returns the dbh - a data base handle of class L<DBI>.
760 $self->ensure_connected;
764 sub _sql_maker_args {
767 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
772 unless ($self->_sql_maker) {
773 my $sql_maker_class = $self->sql_maker_class;
774 $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
776 return $self->_sql_maker;
783 my @info = @{$self->_dbi_connect_info || []};
784 $self->_dbh($self->_connect(@info));
786 # Always set the transaction depth on connect, since
787 # there is no transaction in progress by definition
788 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
790 if(ref $self eq 'DBIx::Class::Storage::DBI') {
791 my $driver = $self->_dbh->{Driver}->{Name};
792 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
793 bless $self, "DBIx::Class::Storage::DBI::${driver}";
798 my $connection_do = $self->on_connect_do;
799 $self->_do_connection_actions($connection_do) if ref($connection_do);
801 $self->_conn_pid($$);
802 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
805 sub _do_connection_actions {
807 my $connection_do = shift;
809 if (ref $connection_do eq 'ARRAY') {
810 $self->_do_query($_) foreach @$connection_do;
812 elsif (ref $connection_do eq 'CODE') {
820 my ($self, $action) = @_;
822 if (ref $action eq 'CODE') {
823 $action = $action->($self);
824 $self->_do_query($_) foreach @$action;
827 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
828 $self->_query_start(@to_run);
829 $self->_dbh->do(@to_run);
830 $self->_query_end(@to_run);
837 my ($self, @info) = @_;
839 $self->throw_exception("You failed to provide any connection info")
842 my ($old_connect_via, $dbh);
844 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
845 $old_connect_via = $DBI::connect_via;
846 $DBI::connect_via = 'connect';
850 if(ref $info[0] eq 'CODE') {
854 $dbh = DBI->connect(@info);
857 if($dbh && !$self->unsafe) {
858 my $weak_self = $self;
860 $dbh->{HandleError} = sub {
861 $weak_self->throw_exception("DBI Exception: $_[0]")
863 $dbh->{ShowErrorStatement} = 1;
864 $dbh->{RaiseError} = 1;
865 $dbh->{PrintError} = 0;
869 $DBI::connect_via = $old_connect_via if $old_connect_via;
871 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
874 $self->_dbh_autocommit($dbh->{AutoCommit});
880 my ($self, $name) = @_;
882 $name = $self->_svp_generate_name
883 unless defined $name;
885 $self->throw_exception ("You can't use savepoints outside a transaction")
886 if $self->{transaction_depth} == 0;
888 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
889 unless $self->can('_svp_begin');
891 push @{ $self->{savepoints} }, $name;
893 $self->debugobj->svp_begin($name) if $self->debug;
895 return $self->_svp_begin($name);
899 my ($self, $name) = @_;
901 $self->throw_exception ("You can't use savepoints outside a transaction")
902 if $self->{transaction_depth} == 0;
904 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
905 unless $self->can('_svp_release');
908 $self->throw_exception ("Savepoint '$name' does not exist")
909 unless grep { $_ eq $name } @{ $self->{savepoints} };
911 # Dig through the stack until we find the one we are releasing. This keeps
912 # the stack up to date.
915 do { $svp = pop @{ $self->{savepoints} } } while $svp ne $name;
917 $name = pop @{ $self->{savepoints} };
920 $self->debugobj->svp_release($name) if $self->debug;
922 return $self->_svp_release($name);
926 my ($self, $name) = @_;
928 $self->throw_exception ("You can't use savepoints outside a transaction")
929 if $self->{transaction_depth} == 0;
931 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
932 unless $self->can('_svp_rollback');
935 # If they passed us a name, verify that it exists in the stack
936 unless(grep({ $_ eq $name } @{ $self->{savepoints} })) {
937 $self->throw_exception("Savepoint '$name' does not exist!");
940 # Dig through the stack until we find the one we are releasing. This keeps
941 # the stack up to date.
942 while(my $s = pop(@{ $self->{savepoints} })) {
943 last if($s eq $name);
945 # Add the savepoint back to the stack, as a rollback doesn't remove the
946 # named savepoint, only everything after it.
947 push(@{ $self->{savepoints} }, $name);
949 # We'll assume they want to rollback to the last savepoint
950 $name = $self->{savepoints}->[-1];
953 $self->debugobj->svp_rollback($name) if $self->debug;
955 return $self->_svp_rollback($name);
958 sub _svp_generate_name {
961 return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
966 $self->ensure_connected();
967 if($self->{transaction_depth} == 0) {
968 $self->debugobj->txn_begin()
970 # this isn't ->_dbh-> because
971 # we should reconnect on begin_work
972 # for AutoCommit users
973 $self->dbh->begin_work;
974 } elsif ($self->auto_savepoint) {
977 $self->{transaction_depth}++;
982 if ($self->{transaction_depth} == 1) {
983 my $dbh = $self->_dbh;
984 $self->debugobj->txn_commit()
987 $self->{transaction_depth} = 0
988 if $self->_dbh_autocommit;
990 elsif($self->{transaction_depth} > 1) {
991 $self->{transaction_depth}--;
993 if $self->auto_savepoint;
999 my $dbh = $self->_dbh;
1001 if ($self->{transaction_depth} == 1) {
1002 $self->debugobj->txn_rollback()
1004 $self->{transaction_depth} = 0
1005 if $self->_dbh_autocommit;
1008 elsif($self->{transaction_depth} > 1) {
1009 $self->{transaction_depth}--;
1010 if ($self->auto_savepoint) {
1011 $self->svp_rollback;
1016 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
1021 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
1022 $error =~ /$exception_class/ and $self->throw_exception($error);
1023 # ensure that a failed rollback resets the transaction depth
1024 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
1025 $self->throw_exception($error);
1029 # This used to be the top-half of _execute. It was split out to make it
1030 # easier to override in NoBindVars without duping the rest. It takes up
1031 # all of _execute's args, and emits $sql, @bind.
1032 sub _prep_for_execute {
1033 my ($self, $op, $extra_bind, $ident, $args) = @_;
1035 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
1037 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
1040 return ($sql, \@bind);
1043 sub _fix_bind_params {
1044 my ($self, @bind) = @_;
1046 ### Turn @bind from something like this:
1047 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
1049 ### ( "'1'", "'1'", "'3'" )
1052 if ( defined( $_ && $_->[1] ) ) {
1053 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
1060 my ( $self, $sql, @bind ) = @_;
1062 if ( $self->debug ) {
1063 @bind = $self->_fix_bind_params(@bind);
1064 $self->debugobj->query_start( $sql, @bind );
1069 my ( $self, $sql, @bind ) = @_;
1071 if ( $self->debug ) {
1072 @bind = $self->_fix_bind_params(@bind);
1073 $self->debugobj->query_end( $sql, @bind );
1078 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
1080 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
1081 $ident = $ident->from();
1084 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
1086 $self->_query_start( $sql, @$bind );
1088 my $sth = $self->sth($sql,$op);
1090 my $placeholder_index = 1;
1092 foreach my $bound (@$bind) {
1093 my $attributes = {};
1094 my($column_name, @data) = @$bound;
1096 if ($bind_attributes) {
1097 $attributes = $bind_attributes->{$column_name}
1098 if defined $bind_attributes->{$column_name};
1101 foreach my $data (@data) {
1102 $data = ref $data ? ''.$data : $data; # stringify args
1104 $sth->bind_param($placeholder_index, $data, $attributes);
1105 $placeholder_index++;
1109 # Can this fail without throwing an exception anyways???
1110 my $rv = $sth->execute();
1111 $self->throw_exception($sth->errstr) if !$rv;
1113 $self->_query_end( $sql, @$bind );
1115 return (wantarray ? ($rv, $sth, @$bind) : $rv);
1120 $self->dbh_do('_dbh_execute', @_)
1124 my ($self, $source, $to_insert) = @_;
1126 my $ident = $source->from;
1127 my $bind_attributes = $self->source_bind_attributes($source);
1129 foreach my $col ( $source->columns ) {
1130 if ( !defined $to_insert->{$col} ) {
1131 my $col_info = $source->column_info($col);
1133 if ( $col_info->{auto_nextval} ) {
1134 $self->ensure_connected;
1135 $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
1140 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1145 ## Still not quite perfect, and EXPERIMENTAL
1146 ## Currently it is assumed that all values passed will be "normal", i.e. not
1147 ## scalar refs, or at least, all the same type as the first set, the statement is
1148 ## only prepped once.
1150 my ($self, $source, $cols, $data) = @_;
1152 my $table = $source->from;
1153 @colvalues{@$cols} = (0..$#$cols);
1154 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
1156 $self->_query_start( $sql, @bind );
1157 my $sth = $self->sth($sql);
1159 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1161 ## This must be an arrayref, else nothing works!
1163 my $tuple_status = [];
1166 ##print STDERR Dumper( $data, $sql, [@bind] );
1170 ## Get the bind_attributes, if any exist
1171 my $bind_attributes = $self->source_bind_attributes($source);
1173 ## Bind the values and execute
1174 my $placeholder_index = 1;
1176 foreach my $bound (@bind) {
1178 my $attributes = {};
1179 my ($column_name, $data_index) = @$bound;
1181 if( $bind_attributes ) {
1182 $attributes = $bind_attributes->{$column_name}
1183 if defined $bind_attributes->{$column_name};
1186 my @data = map { $_->[$data_index] } @$data;
1188 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1189 $placeholder_index++;
1191 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1192 $self->throw_exception($sth->errstr) if !$rv;
1194 $self->_query_end( $sql, @bind );
1195 return (wantarray ? ($rv, $sth, @bind) : $rv);
1199 my $self = shift @_;
1200 my $source = shift @_;
1201 my $bind_attributes = $self->source_bind_attributes($source);
1203 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1208 my $self = shift @_;
1209 my $source = shift @_;
1211 my $bind_attrs = {}; ## If ever it's needed...
1213 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1217 my ($self, $ident, $select, $condition, $attrs) = @_;
1218 my $order = $attrs->{order_by};
1220 if (ref $condition eq 'SCALAR') {
1221 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1224 my $for = delete $attrs->{for};
1225 my $sql_maker = $self->sql_maker;
1226 local $sql_maker->{for} = $for;
1228 if (exists $attrs->{group_by} || $attrs->{having}) {
1230 group_by => $attrs->{group_by},
1231 having => $attrs->{having},
1232 ($order ? (order_by => $order) : ())
1235 my $bind_attrs = {}; ## Future support
1236 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1237 if ($attrs->{software_limit} ||
1238 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1239 $attrs->{software_limit} = 1;
1241 $self->throw_exception("rows attribute must be positive if present")
1242 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1244 # MySQL actually recommends this approach. I cringe.
1245 $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
1246 push @args, $attrs->{rows}, $attrs->{offset};
1249 return $self->_execute(@args);
1252 sub source_bind_attributes {
1253 my ($self, $source) = @_;
1255 my $bind_attributes;
1256 foreach my $column ($source->columns) {
1258 my $data_type = $source->column_info($column)->{data_type} || '';
1259 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1263 return $bind_attributes;
1270 =item Arguments: $ident, $select, $condition, $attrs
1274 Handle a SQL select statement.
1280 my ($ident, $select, $condition, $attrs) = @_;
1281 return $self->cursor_class->new($self, \@_, $attrs);
1286 my ($rv, $sth, @bind) = $self->_select(@_);
1287 my @row = $sth->fetchrow_array;
1288 # Need to call finish() to work round broken DBDs
1297 =item Arguments: $sql
1301 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1306 my ($self, $dbh, $sql) = @_;
1308 # 3 is the if_active parameter which avoids active sth re-use
1309 my $sth = $self->disable_sth_caching
1310 ? $dbh->prepare($sql)
1311 : $dbh->prepare_cached($sql, {}, 3);
1313 # XXX You would think RaiseError would make this impossible,
1314 # but apparently that's not true :(
1315 $self->throw_exception($dbh->errstr) if !$sth;
1321 my ($self, $sql) = @_;
1322 $self->dbh_do('_dbh_sth', $sql);
1325 sub _dbh_columns_info_for {
1326 my ($self, $dbh, $table) = @_;
1328 if ($dbh->can('column_info')) {
1331 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1332 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1334 while ( my $info = $sth->fetchrow_hashref() ){
1336 $column_info{data_type} = $info->{TYPE_NAME};
1337 $column_info{size} = $info->{COLUMN_SIZE};
1338 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1339 $column_info{default_value} = $info->{COLUMN_DEF};
1340 my $col_name = $info->{COLUMN_NAME};
1341 $col_name =~ s/^\"(.*)\"$/$1/;
1343 $result{$col_name} = \%column_info;
1346 return \%result if !$@ && scalar keys %result;
1350 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1352 my @columns = @{$sth->{NAME_lc}};
1353 for my $i ( 0 .. $#columns ){
1355 $column_info{data_type} = $sth->{TYPE}->[$i];
1356 $column_info{size} = $sth->{PRECISION}->[$i];
1357 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1359 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1360 $column_info{data_type} = $1;
1361 $column_info{size} = $2;
1364 $result{$columns[$i]} = \%column_info;
1368 foreach my $col (keys %result) {
1369 my $colinfo = $result{$col};
1370 my $type_num = $colinfo->{data_type};
1372 if(defined $type_num && $dbh->can('type_info')) {
1373 my $type_info = $dbh->type_info($type_num);
1374 $type_name = $type_info->{TYPE_NAME} if $type_info;
1375 $colinfo->{data_type} = $type_name if $type_name;
1382 sub columns_info_for {
1383 my ($self, $table) = @_;
1384 $self->dbh_do('_dbh_columns_info_for', $table);
1387 =head2 last_insert_id
1389 Return the row id of the last insert.
1393 sub _dbh_last_insert_id {
1394 my ($self, $dbh, $source, $col) = @_;
1395 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1396 $dbh->func('last_insert_rowid');
1399 sub last_insert_id {
1401 $self->dbh_do('_dbh_last_insert_id', @_);
1406 Returns the database driver name.
1410 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1412 =head2 bind_attribute_by_data_type
1414 Given a datatype from column info, returns a database specific bind attribute for
1415 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1418 Generally only needed for special case column types, like bytea in postgres.
1422 sub bind_attribute_by_data_type {
1426 =head2 create_ddl_dir
1430 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1434 Creates a SQL file based on the Schema, for each of the specified
1435 database types, in the given directory.
1441 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1443 if(!$dir || !-d $dir)
1445 warn "No directory given, using ./\n";
1448 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1449 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1450 $version ||= $schema->VERSION || '1.x';
1451 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1453 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
1454 . $self->_check_sqlt_message . q{'})
1455 if !$self->_check_sqlt_version;
1457 my $sqlt = SQL::Translator->new( $sqltargs );
1459 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1460 my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
1462 foreach my $db (@$databases)
1465 $sqlt = $self->configure_sqlt($sqlt, $db);
1466 $sqlt->{schema} = $sqlt_schema;
1467 $sqlt->producer($db);
1470 my $filename = $schema->ddl_filename($db, $dir, $version);
1473 warn("$filename already exists, skipping $db");
1474 next unless ($preversion);
1476 my $output = $sqlt->translate;
1479 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1482 if(!open($file, ">$filename"))
1484 $self->throw_exception("Can't open $filename for writing ($!)");
1487 print $file $output;
1492 require SQL::Translator::Diff;
1494 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1495 # print "Previous version $prefilename\n";
1496 if(!-e $prefilename)
1498 warn("No previous schema file found ($prefilename)");
1502 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1503 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1506 warn("$difffile already exists, skipping");
1512 my $t = SQL::Translator->new($sqltargs);
1515 $t->parser( $db ) or die $t->error;
1516 $t = $self->configure_sqlt($t, $db);
1517 my $out = $t->translate( $prefilename ) or die $t->error;
1518 $source_schema = $t->schema;
1519 unless ( $source_schema->name ) {
1520 $source_schema->name( $prefilename );
1524 # The "new" style of producers have sane normalization and can support
1525 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
1526 # And we have to diff parsed SQL against parsed SQL.
1527 my $dest_schema = $sqlt_schema;
1529 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
1530 my $t = SQL::Translator->new($sqltargs);
1533 $t->parser( $db ) or die $t->error;
1534 $t = $self->configure_sqlt($t, $db);
1535 my $out = $t->translate( $filename ) or die $t->error;
1536 $dest_schema = $t->schema;
1537 $dest_schema->name( $filename )
1538 unless $dest_schema->name;
1542 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1546 if(!open $file, ">$difffile")
1548 $self->throw_exception("Can't write to $difffile ($!)");
1557 sub configure_sqlt() {
1560 my $db = shift || $self->sqlt_type;
1561 if ($db eq 'PostgreSQL') {
1562 $tr->quote_table_names(0);
1563 $tr->quote_field_names(0);
1568 =head2 deployment_statements
1572 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1576 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1577 The database driver name is given by C<$type>, though the value from
1578 L</sqlt_type> is used if it is not specified.
1580 C<$directory> is used to return statements from files in a previously created
1581 L</create_ddl_dir> directory and is optional. The filenames are constructed
1582 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1584 If no C<$directory> is specified then the statements are constructed on the
1585 fly using L<SQL::Translator> and C<$version> is ignored.
1587 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1591 sub deployment_statements {
1592 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1593 # Need to be connected to get the correct sqlt_type
1594 $self->ensure_connected() unless $type;
1595 $type ||= $self->sqlt_type;
1596 $version ||= $schema->VERSION || '1.x';
1598 my $filename = $schema->ddl_filename($type, $dir, $version);
1602 open($file, "<$filename")
1603 or $self->throw_exception("Can't open $filename ($!)");
1606 return join('', @rows);
1609 $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
1610 . $self->_check_sqlt_message . q{'})
1611 if !$self->_check_sqlt_version;
1613 require SQL::Translator::Parser::DBIx::Class;
1614 eval qq{use SQL::Translator::Producer::${type}};
1615 $self->throw_exception($@) if $@;
1617 # sources needs to be a parser arg, but for simplicty allow at top level
1619 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1620 if exists $sqltargs->{sources};
1622 my $tr = SQL::Translator->new(%$sqltargs);
1623 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1624 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1631 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1632 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1633 foreach my $line ( split(";\n", $statement)) {
1634 next if($line =~ /^--/);
1636 # next if($line =~ /^DROP/m);
1637 next if($line =~ /^BEGIN TRANSACTION/m);
1638 next if($line =~ /^COMMIT/m);
1639 next if $line =~ /^\s+$/; # skip whitespace only
1640 $self->_query_start($line);
1642 $self->dbh->do($line); # shouldn't be using ->dbh ?
1645 warn qq{$@ (running "${line}")};
1647 $self->_query_end($line);
1652 =head2 datetime_parser
1654 Returns the datetime parser class
1658 sub datetime_parser {
1660 return $self->{datetime_parser} ||= do {
1661 $self->ensure_connected;
1662 $self->build_datetime_parser(@_);
1666 =head2 datetime_parser_type
1668 Defines (returns) the datetime parser class - currently hardwired to
1669 L<DateTime::Format::MySQL>
1673 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1675 =head2 build_datetime_parser
1677 See L</datetime_parser>
1681 sub build_datetime_parser {
1683 my $type = $self->datetime_parser_type(@_);
1685 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1690 my $_check_sqlt_version; # private
1691 my $_check_sqlt_message; # private
1692 sub _check_sqlt_version {
1693 return $_check_sqlt_version if defined $_check_sqlt_version;
1694 eval 'use SQL::Translator "0.09"';
1695 $_check_sqlt_message = $@ || '';
1696 $_check_sqlt_version = !$@;
1699 sub _check_sqlt_message {
1700 _check_sqlt_version if !defined $_check_sqlt_message;
1701 $_check_sqlt_message;
1707 return if !$self->_dbh;
1716 The module defines a set of methods within the DBIC::SQL::Abstract
1717 namespace. These build on L<SQL::Abstract::Limit> to provide the
1718 SQL query functions.
1720 The following methods are extended:-
1734 See L</connect_info> for details.
1735 For setting, this method is deprecated in favor of L</connect_info>.
1739 See L</connect_info> for details.
1740 For setting, this method is deprecated in favor of L</connect_info>.
1744 See L</connect_info> for details.
1745 For setting, this method is deprecated in favor of L</connect_info>.
1751 Matt S. Trout <mst@shadowcatsystems.co.uk>
1753 Andy Grundman <andy@hybridized.org>
1757 You may distribute this code under the same terms as Perl itself.