1 package DBIx::Class::Storage::DBI;
2 # -*- mode: cperl; cperl-indent-level: 2 -*-
4 use base 'DBIx::Class::Storage';
8 use Carp::Clan qw/^DBIx::Class/;
10 use SQL::Abstract::Limit;
11 use DBIx::Class::Storage::DBI::Cursor;
12 use DBIx::Class::Storage::Statistics;
13 use Scalar::Util qw/blessed weaken/;
15 __PACKAGE__->mk_group_accessors('simple' =>
16 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
17 _conn_pid _conn_tid disable_sth_caching on_connect_do
18 on_disconnect_do transaction_depth unsafe _dbh_autocommit
19 auto_savepoint savepoints/
22 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
24 __PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
25 __PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
29 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
31 use base qw/SQL::Abstract::Limit/;
33 # This prevents the caching of $dbh in S::A::L, I believe
35 my $self = shift->SUPER::new(@_);
37 # If limit_dialect is a ref (like a $dbh), go ahead and replace
38 # it with what it resolves to:
39 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
40 if ref $self->{limit_dialect};
46 my ($self, $sql, $order, $rows, $offset ) = @_;
49 my $last = $rows + $offset;
50 my ( $order_by ) = $self->_order_by( $order );
55 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
60 WHERE ROW_NUM BETWEEN $offset AND $last
66 # While we're at it, this should make LIMIT queries more efficient,
67 # without digging into things too deeply
68 use Scalar::Util 'blessed';
70 my ($self, $syntax) = @_;
71 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
72 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
73 return 'RowNumberOver';
76 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
80 my ($self, $table, $fields, $where, $order, @rest) = @_;
81 $table = $self->_quote($table) unless ref($table);
82 local $self->{rownum_hack_count} = 1
83 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
84 @rest = (-1) unless defined $rest[0];
85 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
86 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
87 local $self->{having_bind} = [];
88 my ($sql, @ret) = $self->SUPER::select(
89 $table, $self->_recurse_fields($fields), $where, $order, @rest
94 $self->{for} eq 'update' ? ' FOR UPDATE' :
95 $self->{for} eq 'shared' ? ' FOR SHARE' :
100 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
106 $table = $self->_quote($table) unless ref($table);
107 $self->SUPER::insert($table, @_);
113 $table = $self->_quote($table) unless ref($table);
114 $self->SUPER::update($table, @_);
120 $table = $self->_quote($table) unless ref($table);
121 $self->SUPER::delete($table, @_);
127 return $_[1].$self->_order_by($_[2]);
129 return $self->SUPER::_emulate_limit(@_);
133 sub _recurse_fields {
134 my ($self, $fields, $params) = @_;
135 my $ref = ref $fields;
136 return $self->_quote($fields) unless $ref;
137 return $$fields if $ref eq 'SCALAR';
139 if ($ref eq 'ARRAY') {
140 return join(', ', map {
141 $self->_recurse_fields($_)
142 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
143 ? ' AS col'.$self->{rownum_hack_count}++
146 } elsif ($ref eq 'HASH') {
147 foreach my $func (keys %$fields) {
148 return $self->_sqlcase($func)
149 .'( '.$self->_recurse_fields($fields->{$func}).' )';
158 if (ref $_[0] eq 'HASH') {
159 if (defined $_[0]->{group_by}) {
160 $ret = $self->_sqlcase(' group by ')
161 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
163 if (defined $_[0]->{having}) {
165 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
166 push(@{$self->{having_bind}}, @extra);
167 $ret .= $self->_sqlcase(' having ').$frag;
169 if (defined $_[0]->{order_by}) {
170 $ret .= $self->_order_by($_[0]->{order_by});
172 } elsif (ref $_[0] eq 'SCALAR') {
173 $ret = $self->_sqlcase(' order by ').${ $_[0] };
174 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
175 my @order = @{+shift};
176 $ret = $self->_sqlcase(' order by ')
178 my $r = $self->_order_by($_, @_);
179 $r =~ s/^ ?ORDER BY //i;
183 $ret = $self->SUPER::_order_by(@_);
188 sub _order_directions {
189 my ($self, $order) = @_;
190 $order = $order->{order_by} if ref $order eq 'HASH';
191 return $self->SUPER::_order_directions($order);
195 my ($self, $from) = @_;
196 if (ref $from eq 'ARRAY') {
197 return $self->_recurse_from(@$from);
198 } elsif (ref $from eq 'HASH') {
199 return $self->_make_as($from);
201 return $from; # would love to quote here but _table ends up getting called
202 # twice during an ->select without a limit clause due to
203 # the way S::A::Limit->select works. should maybe consider
204 # bypassing this and doing S::A::select($self, ...) in
205 # our select method above. meantime, quoting shims have
206 # been added to select/insert/update/delete here
211 my ($self, $from, @join) = @_;
213 push(@sqlf, $self->_make_as($from));
214 foreach my $j (@join) {
217 # check whether a join type exists
218 my $join_clause = '';
219 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
220 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
221 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
223 $join_clause = ' JOIN ';
225 push(@sqlf, $join_clause);
227 if (ref $to eq 'ARRAY') {
228 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
230 push(@sqlf, $self->_make_as($to));
232 push(@sqlf, ' ON ', $self->_join_condition($on));
234 return join('', @sqlf);
238 my ($self, $from) = @_;
239 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
240 reverse each %{$self->_skip_options($from)});
244 my ($self, $hash) = @_;
246 $clean_hash->{$_} = $hash->{$_}
247 for grep {!/^-/} keys %$hash;
251 sub _join_condition {
252 my ($self, $cond) = @_;
253 if (ref $cond eq 'HASH') {
258 # XXX no throw_exception() in this package and croak() fails with strange results
259 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
260 if ref($v) ne 'SCALAR';
264 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
267 return scalar($self->_recurse_where(\%j));
268 } elsif (ref $cond eq 'ARRAY') {
269 return join(' OR ', map { $self->_join_condition($_) } @$cond);
271 die "Can't handle this yet!";
276 my ($self, $label) = @_;
277 return '' unless defined $label;
278 return "*" if $label eq '*';
279 return $label unless $self->{quote_char};
280 if(ref $self->{quote_char} eq "ARRAY"){
281 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
282 if !defined $self->{name_sep};
283 my $sep = $self->{name_sep};
284 return join($self->{name_sep},
285 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
286 split(/\Q$sep\E/,$label));
288 return $self->SUPER::_quote($label);
293 $self->{limit_dialect} = shift if @_;
294 return $self->{limit_dialect};
299 $self->{quote_char} = shift if @_;
300 return $self->{quote_char};
305 $self->{name_sep} = shift if @_;
306 return $self->{name_sep};
309 } # End of BEGIN block
313 DBIx::Class::Storage::DBI - DBI storage handler
319 This class represents the connection to an RDBMS via L<DBI>. See
320 L<DBIx::Class::Storage> for general information. This pod only
321 documents DBI-specific methods and behaviors.
328 my $new = shift->next::method(@_);
330 $new->transaction_depth(0);
331 $new->_sql_maker_opts({});
332 $new->{savepoints} = [];
333 $new->{_in_dbh_do} = 0;
334 $new->{_dbh_gen} = 0;
341 The arguments of C<connect_info> are always a single array reference.
343 This is normally accessed via L<DBIx::Class::Schema/connection>, which
344 encapsulates its argument list in an arrayref before calling
345 C<connect_info> here.
347 The arrayref can either contain the same set of arguments one would
348 normally pass to L<DBI/connect>, or a lone code reference which returns
349 a connected database handle. Please note that the L<DBI> docs
350 recommend that you always explicitly set C<AutoCommit> to either
351 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
352 to C<1>, and that you perform transactions via our L</txn_do>
353 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
354 set it to zero. This is the default for most DBDs. See below for more
357 In either case, if the final argument in your connect_info happens
358 to be a hashref, C<connect_info> will look there for several
359 connection-specific options:
365 Specifies things to do immediately after connecting or re-connecting to
366 the database. Its value may contain:
370 =item an array reference
372 This contains SQL statements to execute in order. Each element contains
373 a string or a code reference that returns a string.
375 =item a code reference
377 This contains some code to execute. Unlike code references within an
378 array reference, its return value is ignored.
382 =item on_disconnect_do
384 Takes arguments in the same form as L<on_connect_do> and executes them
385 immediately before disconnecting from the database.
387 Note, this only runs if you explicitly call L<disconnect> on the
390 =item disable_sth_caching
392 If set to a true value, this option will disable the caching of
393 statement handles via L<DBI/prepare_cached>.
397 Sets the limit dialect. This is useful for JDBC-bridge among others
398 where the remote SQL-dialect cannot be determined by the name of the
403 Specifies what characters to use to quote table and column names. If
404 you use this you will want to specify L<name_sep> as well.
406 quote_char expects either a single character, in which case is it is placed
407 on either side of the table/column, or an arrayref of length 2 in which case the
408 table/column name is placed between the elements.
410 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
411 use C<quote_char =E<gt> [qw/[ ]/]>.
415 This only needs to be used in conjunction with L<quote_char>, and is used to
416 specify the charecter that seperates elements (schemas, tables, columns) from
417 each other. In most cases this is simply a C<.>.
421 This Storage driver normally installs its own C<HandleError>, sets
422 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
423 all database handles, including those supplied by a coderef. It does this
424 so that it can have consistent and useful error behavior.
426 If you set this option to a true value, Storage will not do its usual
427 modifications to the database handle's attributes, and instead relies on
428 the settings in your connect_info DBI options (or the values you set in
429 your connection coderef, in the case that you are connecting via coderef).
431 Note that your custom settings can cause Storage to malfunction,
432 especially if you set a C<HandleError> handler that suppresses exceptions
433 and/or disable C<RaiseError>.
437 If this option is true, L<DBIx::Class> will use savepoints when nesting
438 transactions, making it possible to recover from failure in the inner
439 transaction without having to abort all outer transactions.
443 These options can be mixed in with your other L<DBI> connection attributes,
444 or placed in a seperate hashref after all other normal L<DBI> connection
447 Every time C<connect_info> is invoked, any previous settings for
448 these options will be cleared before setting the new ones, regardless of
449 whether any options are specified in the new C<connect_info>.
451 Another Important Note:
453 DBIC can do some wonderful magic with handling exceptions,
454 disconnections, and transactions when you use C<< AutoCommit => 1 >>
455 combined with C<txn_do> for transaction support.
457 If you set C<< AutoCommit => 0 >> in your connect info, then you are always
458 in an assumed transaction between commits, and you're telling us you'd
459 like to manage that manually. A lot of DBIC's magic protections
460 go away. We can't protect you from exceptions due to database
461 disconnects because we don't know anything about how to restart your
462 transactions. You're on your own for handling all sorts of exceptional
463 cases if you choose the C<< AutoCommit => 0 >> path, just as you would
468 # Simple SQLite connection
469 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
472 ->connect_info([ sub { DBI->connect(...) } ]);
474 # A bit more complicated
481 { quote_char => q{"}, name_sep => q{.} },
485 # Equivalent to the previous example
491 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
495 # Subref + DBIC-specific connection options
498 sub { DBI->connect(...) },
502 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
503 disable_sth_caching => 1,
511 my ($self, $info_arg) = @_;
513 return $self->_connect_info if !$info_arg;
515 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
516 # the new set of options
517 $self->_sql_maker(undef);
518 $self->_sql_maker_opts({});
519 $self->_connect_info([@$info_arg]); # copy for _connect_info
521 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
523 my $last_info = $dbi_info->[-1];
524 if(ref $last_info eq 'HASH') {
525 $last_info = { %$last_info }; # so delete is non-destructive
526 my @storage_option = qw(
527 on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
530 for my $storage_opt (@storage_option) {
531 if(my $value = delete $last_info->{$storage_opt}) {
532 $self->$storage_opt($value);
535 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
536 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
537 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
540 # re-insert modified hashref
541 $dbi_info->[-1] = $last_info;
543 # Get rid of any trailing empty hashref
544 pop(@$dbi_info) if !keys %$last_info;
546 $self->_dbi_connect_info($dbi_info);
548 $self->_connect_info;
553 This method is deprecated in favor of setting via L</connect_info>.
557 Arguments: ($subref | $method_name), @extra_coderef_args?
559 Execute the given $subref or $method_name using the new exception-based
560 connection management.
562 The first two arguments will be the storage object that C<dbh_do> was called
563 on and a database handle to use. Any additional arguments will be passed
564 verbatim to the called subref as arguments 2 and onwards.
566 Using this (instead of $self->_dbh or $self->dbh) ensures correct
567 exception handling and reconnection (or failover in future subclasses).
569 Your subref should have no side-effects outside of the database, as
570 there is the potential for your subref to be partially double-executed
571 if the database connection was stale/dysfunctional.
575 my @stuff = $schema->storage->dbh_do(
577 my ($storage, $dbh, @cols) = @_;
578 my $cols = join(q{, }, @cols);
579 $dbh->selectrow_array("SELECT $cols FROM foo");
590 my $dbh = $self->_dbh;
592 return $self->$code($dbh, @_) if $self->{_in_dbh_do}
593 || $self->{transaction_depth};
595 local $self->{_in_dbh_do} = 1;
598 my $want_array = wantarray;
601 $self->_verify_pid if $dbh;
603 $self->_populate_dbh;
608 @result = $self->$code($dbh, @_);
610 elsif(defined $want_array) {
611 $result[0] = $self->$code($dbh, @_);
614 $self->$code($dbh, @_);
619 if(!$exception) { return $want_array ? @result : $result[0] }
621 $self->throw_exception($exception) if $self->connected;
623 # We were not connected - reconnect and retry, but let any
624 # exception fall right through this time
625 $self->_populate_dbh;
626 $self->$code($self->_dbh, @_);
629 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
630 # It also informs dbh_do to bypass itself while under the direction of txn_do,
631 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
636 ref $coderef eq 'CODE' or $self->throw_exception
637 ('$coderef must be a CODE reference');
639 return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
641 local $self->{_in_dbh_do} = 1;
644 my $want_array = wantarray;
649 $self->_verify_pid if $self->_dbh;
650 $self->_populate_dbh if !$self->_dbh;
654 @result = $coderef->(@_);
656 elsif(defined $want_array) {
657 $result[0] = $coderef->(@_);
666 if(!$exception) { return $want_array ? @result : $result[0] }
668 if($tried++ > 0 || $self->connected) {
669 eval { $self->txn_rollback };
670 my $rollback_exception = $@;
671 if($rollback_exception) {
672 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
673 $self->throw_exception($exception) # propagate nested rollback
674 if $rollback_exception =~ /$exception_class/;
676 $self->throw_exception(
677 "Transaction aborted: ${exception}. "
678 . "Rollback failed: ${rollback_exception}"
681 $self->throw_exception($exception)
684 # We were not connected, and was first try - reconnect and retry
686 $self->_populate_dbh;
692 Our C<disconnect> method also performs a rollback first if the
693 database is not in C<AutoCommit> mode.
700 if( $self->connected ) {
701 my $connection_do = $self->on_disconnect_do;
702 $self->_do_connection_actions($connection_do) if ref($connection_do);
704 $self->_dbh->rollback unless $self->_dbh_autocommit;
705 $self->_dbh->disconnect;
714 if(my $dbh = $self->_dbh) {
715 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
722 return 0 if !$self->_dbh;
724 return ($dbh->FETCH('Active') && $dbh->ping);
730 # handle pid changes correctly
731 # NOTE: assumes $self->_dbh is a valid $dbh
735 return if defined $self->_conn_pid && $self->_conn_pid == $$;
737 $self->_dbh->{InactiveDestroy} = 1;
744 sub ensure_connected {
747 unless ($self->connected) {
748 $self->_populate_dbh;
754 Returns the dbh - a data base handle of class L<DBI>.
761 $self->ensure_connected;
765 sub _sql_maker_args {
768 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
773 unless ($self->_sql_maker) {
774 my $sql_maker_class = $self->sql_maker_class;
775 $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
777 return $self->_sql_maker;
784 my @info = @{$self->_dbi_connect_info || []};
785 $self->_dbh($self->_connect(@info));
787 # Always set the transaction depth on connect, since
788 # there is no transaction in progress by definition
789 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
791 if(ref $self eq 'DBIx::Class::Storage::DBI') {
792 my $driver = $self->_dbh->{Driver}->{Name};
793 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
794 bless $self, "DBIx::Class::Storage::DBI::${driver}";
799 my $connection_do = $self->on_connect_do;
800 $self->_do_connection_actions($connection_do) if ref($connection_do);
802 $self->_conn_pid($$);
803 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
806 sub _do_connection_actions {
808 my $connection_do = shift;
810 if (ref $connection_do eq 'ARRAY') {
811 $self->_do_query($_) foreach @$connection_do;
813 elsif (ref $connection_do eq 'CODE') {
821 my ($self, $action) = @_;
823 if (ref $action eq 'CODE') {
824 $action = $action->($self);
825 $self->_do_query($_) foreach @$action;
828 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
829 $self->_query_start(@to_run);
830 $self->_dbh->do(@to_run);
831 $self->_query_end(@to_run);
838 my ($self, @info) = @_;
840 $self->throw_exception("You failed to provide any connection info")
843 my ($old_connect_via, $dbh);
845 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
846 $old_connect_via = $DBI::connect_via;
847 $DBI::connect_via = 'connect';
851 if(ref $info[0] eq 'CODE') {
855 $dbh = DBI->connect(@info);
858 if($dbh && !$self->unsafe) {
859 my $weak_self = $self;
861 $dbh->{HandleError} = sub {
862 $weak_self->throw_exception("DBI Exception: $_[0]")
864 $dbh->{ShowErrorStatement} = 1;
865 $dbh->{RaiseError} = 1;
866 $dbh->{PrintError} = 0;
870 $DBI::connect_via = $old_connect_via if $old_connect_via;
872 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
875 $self->_dbh_autocommit($dbh->{AutoCommit});
881 my ($self, $name) = @_;
883 $name = $self->_svp_generate_name
884 unless defined $name;
886 $self->throw_exception ("You can't use savepoints outside a transaction")
887 if $self->{transaction_depth} == 0;
889 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
890 unless $self->can('_svp_begin');
892 push @{ $self->{savepoints} }, $name;
894 $self->debugobj->svp_begin($name) if $self->debug;
896 return $self->_svp_begin($name);
900 my ($self, $name) = @_;
902 $self->throw_exception ("You can't use savepoints outside a transaction")
903 if $self->{transaction_depth} == 0;
905 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
906 unless $self->can('_svp_release');
909 $self->throw_exception ("Savepoint '$name' does not exist")
910 unless grep { $_ eq $name } @{ $self->{savepoints} };
912 # Dig through the stack until we find the one we are releasing. This keeps
913 # the stack up to date.
916 do { $svp = pop @{ $self->{savepoints} } } while $svp ne $name;
918 $name = pop @{ $self->{savepoints} };
921 $self->debugobj->svp_release($name) if $self->debug;
923 return $self->_svp_release($name);
927 my ($self, $name) = @_;
929 $self->throw_exception ("You can't use savepoints outside a transaction")
930 if $self->{transaction_depth} == 0;
932 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
933 unless $self->can('_svp_rollback');
936 # If they passed us a name, verify that it exists in the stack
937 unless(grep({ $_ eq $name } @{ $self->{savepoints} })) {
938 $self->throw_exception("Savepoint '$name' does not exist!");
941 # Dig through the stack until we find the one we are releasing. This keeps
942 # the stack up to date.
943 while(my $s = pop(@{ $self->{savepoints} })) {
944 last if($s eq $name);
946 # Add the savepoint back to the stack, as a rollback doesn't remove the
947 # named savepoint, only everything after it.
948 push(@{ $self->{savepoints} }, $name);
950 # We'll assume they want to rollback to the last savepoint
951 $name = $self->{savepoints}->[-1];
954 $self->debugobj->svp_rollback($name) if $self->debug;
956 return $self->_svp_rollback($name);
959 sub _svp_generate_name {
962 return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
967 $self->ensure_connected();
968 if($self->{transaction_depth} == 0) {
969 $self->debugobj->txn_begin()
971 # this isn't ->_dbh-> because
972 # we should reconnect on begin_work
973 # for AutoCommit users
974 $self->dbh->begin_work;
975 } elsif ($self->auto_savepoint) {
978 $self->{transaction_depth}++;
983 if ($self->{transaction_depth} == 1) {
984 my $dbh = $self->_dbh;
985 $self->debugobj->txn_commit()
988 $self->{transaction_depth} = 0
989 if $self->_dbh_autocommit;
991 elsif($self->{transaction_depth} > 1) {
992 $self->{transaction_depth}--;
994 if $self->auto_savepoint;
1000 my $dbh = $self->_dbh;
1002 if ($self->{transaction_depth} == 1) {
1003 $self->debugobj->txn_rollback()
1005 $self->{transaction_depth} = 0
1006 if $self->_dbh_autocommit;
1009 elsif($self->{transaction_depth} > 1) {
1010 $self->{transaction_depth}--;
1011 if ($self->auto_savepoint) {
1012 $self->svp_rollback;
1017 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
1022 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
1023 $error =~ /$exception_class/ and $self->throw_exception($error);
1024 # ensure that a failed rollback resets the transaction depth
1025 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
1026 $self->throw_exception($error);
1030 # This used to be the top-half of _execute. It was split out to make it
1031 # easier to override in NoBindVars without duping the rest. It takes up
1032 # all of _execute's args, and emits $sql, @bind.
1033 sub _prep_for_execute {
1034 my ($self, $op, $extra_bind, $ident, $args) = @_;
1036 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
1038 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
1041 return ($sql, \@bind);
1044 sub _fix_bind_params {
1045 my ($self, @bind) = @_;
1047 ### Turn @bind from something like this:
1048 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
1050 ### ( "'1'", "'1'", "'3'" )
1053 if ( defined( $_ && $_->[1] ) ) {
1054 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
1061 my ( $self, $sql, @bind ) = @_;
1063 if ( $self->debug ) {
1064 @bind = $self->_fix_bind_params(@bind);
1065 $self->debugobj->query_start( $sql, @bind );
1070 my ( $self, $sql, @bind ) = @_;
1072 if ( $self->debug ) {
1073 @bind = $self->_fix_bind_params(@bind);
1074 $self->debugobj->query_end( $sql, @bind );
1079 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
1081 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
1082 $ident = $ident->from();
1085 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
1087 $self->_query_start( $sql, @$bind );
1089 my $sth = $self->sth($sql,$op);
1091 my $placeholder_index = 1;
1093 foreach my $bound (@$bind) {
1094 my $attributes = {};
1095 my($column_name, @data) = @$bound;
1097 if ($bind_attributes) {
1098 $attributes = $bind_attributes->{$column_name}
1099 if defined $bind_attributes->{$column_name};
1102 foreach my $data (@data) {
1103 $data = ref $data ? ''.$data : $data; # stringify args
1105 $sth->bind_param($placeholder_index, $data, $attributes);
1106 $placeholder_index++;
1110 # Can this fail without throwing an exception anyways???
1111 my $rv = $sth->execute();
1112 $self->throw_exception($sth->errstr) if !$rv;
1114 $self->_query_end( $sql, @$bind );
1116 return (wantarray ? ($rv, $sth, @$bind) : $rv);
1121 $self->dbh_do('_dbh_execute', @_)
1125 my ($self, $source, $to_insert) = @_;
1127 my $ident = $source->from;
1128 my $bind_attributes = $self->source_bind_attributes($source);
1130 foreach my $col ( $source->columns ) {
1131 if ( !defined $to_insert->{$col} ) {
1132 my $col_info = $source->column_info($col);
1134 if ( $col_info->{auto_nextval} ) {
1135 $self->ensure_connected;
1136 $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
1141 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1146 ## Still not quite perfect, and EXPERIMENTAL
1147 ## Currently it is assumed that all values passed will be "normal", i.e. not
1148 ## scalar refs, or at least, all the same type as the first set, the statement is
1149 ## only prepped once.
1151 my ($self, $source, $cols, $data) = @_;
1153 my $table = $source->from;
1154 @colvalues{@$cols} = (0..$#$cols);
1155 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
1157 $self->_query_start( $sql, @bind );
1158 my $sth = $self->sth($sql);
1160 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1162 ## This must be an arrayref, else nothing works!
1164 my $tuple_status = [];
1167 ##print STDERR Dumper( $data, $sql, [@bind] );
1171 ## Get the bind_attributes, if any exist
1172 my $bind_attributes = $self->source_bind_attributes($source);
1174 ## Bind the values and execute
1175 my $placeholder_index = 1;
1177 foreach my $bound (@bind) {
1179 my $attributes = {};
1180 my ($column_name, $data_index) = @$bound;
1182 if( $bind_attributes ) {
1183 $attributes = $bind_attributes->{$column_name}
1184 if defined $bind_attributes->{$column_name};
1187 my @data = map { $_->[$data_index] } @$data;
1189 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1190 $placeholder_index++;
1192 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1193 $self->throw_exception($sth->errstr) if !$rv;
1195 $self->_query_end( $sql, @bind );
1196 return (wantarray ? ($rv, $sth, @bind) : $rv);
1200 my $self = shift @_;
1201 my $source = shift @_;
1202 my $bind_attributes = $self->source_bind_attributes($source);
1204 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1209 my $self = shift @_;
1210 my $source = shift @_;
1212 my $bind_attrs = {}; ## If ever it's needed...
1214 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1218 my ($self, $ident, $select, $condition, $attrs) = @_;
1219 my $order = $attrs->{order_by};
1221 if (ref $condition eq 'SCALAR') {
1222 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1225 my $for = delete $attrs->{for};
1226 my $sql_maker = $self->sql_maker;
1227 local $sql_maker->{for} = $for;
1229 if (exists $attrs->{group_by} || $attrs->{having}) {
1231 group_by => $attrs->{group_by},
1232 having => $attrs->{having},
1233 ($order ? (order_by => $order) : ())
1236 my $bind_attrs = {}; ## Future support
1237 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1238 if ($attrs->{software_limit} ||
1239 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1240 $attrs->{software_limit} = 1;
1242 $self->throw_exception("rows attribute must be positive if present")
1243 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1245 # MySQL actually recommends this approach. I cringe.
1246 $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
1247 push @args, $attrs->{rows}, $attrs->{offset};
1250 return $self->_execute(@args);
1253 sub source_bind_attributes {
1254 my ($self, $source) = @_;
1256 my $bind_attributes;
1257 foreach my $column ($source->columns) {
1259 my $data_type = $source->column_info($column)->{data_type} || '';
1260 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1264 return $bind_attributes;
1271 =item Arguments: $ident, $select, $condition, $attrs
1275 Handle a SQL select statement.
1281 my ($ident, $select, $condition, $attrs) = @_;
1282 return $self->cursor_class->new($self, \@_, $attrs);
1287 my ($rv, $sth, @bind) = $self->_select(@_);
1288 my @row = $sth->fetchrow_array;
1289 carp "Query returned more than one row" if $sth->fetchrow_array;
1290 # Need to call finish() to work round broken DBDs
1299 =item Arguments: $sql
1303 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1308 my ($self, $dbh, $sql) = @_;
1310 # 3 is the if_active parameter which avoids active sth re-use
1311 my $sth = $self->disable_sth_caching
1312 ? $dbh->prepare($sql)
1313 : $dbh->prepare_cached($sql, {}, 3);
1315 # XXX You would think RaiseError would make this impossible,
1316 # but apparently that's not true :(
1317 $self->throw_exception($dbh->errstr) if !$sth;
1323 my ($self, $sql) = @_;
1324 $self->dbh_do('_dbh_sth', $sql);
1327 sub _dbh_columns_info_for {
1328 my ($self, $dbh, $table) = @_;
1330 if ($dbh->can('column_info')) {
1333 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1334 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1336 while ( my $info = $sth->fetchrow_hashref() ){
1338 $column_info{data_type} = $info->{TYPE_NAME};
1339 $column_info{size} = $info->{COLUMN_SIZE};
1340 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1341 $column_info{default_value} = $info->{COLUMN_DEF};
1342 my $col_name = $info->{COLUMN_NAME};
1343 $col_name =~ s/^\"(.*)\"$/$1/;
1345 $result{$col_name} = \%column_info;
1348 return \%result if !$@ && scalar keys %result;
1352 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1354 my @columns = @{$sth->{NAME_lc}};
1355 for my $i ( 0 .. $#columns ){
1357 $column_info{data_type} = $sth->{TYPE}->[$i];
1358 $column_info{size} = $sth->{PRECISION}->[$i];
1359 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1361 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1362 $column_info{data_type} = $1;
1363 $column_info{size} = $2;
1366 $result{$columns[$i]} = \%column_info;
1370 foreach my $col (keys %result) {
1371 my $colinfo = $result{$col};
1372 my $type_num = $colinfo->{data_type};
1374 if(defined $type_num && $dbh->can('type_info')) {
1375 my $type_info = $dbh->type_info($type_num);
1376 $type_name = $type_info->{TYPE_NAME} if $type_info;
1377 $colinfo->{data_type} = $type_name if $type_name;
1384 sub columns_info_for {
1385 my ($self, $table) = @_;
1386 $self->dbh_do('_dbh_columns_info_for', $table);
1389 =head2 last_insert_id
1391 Return the row id of the last insert.
1395 sub _dbh_last_insert_id {
1396 my ($self, $dbh, $source, $col) = @_;
1397 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1398 $dbh->func('last_insert_rowid');
1401 sub last_insert_id {
1403 $self->dbh_do('_dbh_last_insert_id', @_);
1408 Returns the database driver name.
1412 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1414 =head2 bind_attribute_by_data_type
1416 Given a datatype from column info, returns a database specific bind attribute for
1417 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1420 Generally only needed for special case column types, like bytea in postgres.
1424 sub bind_attribute_by_data_type {
1428 =head2 create_ddl_dir
1432 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1436 Creates a SQL file based on the Schema, for each of the specified
1437 database types, in the given directory.
1443 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1445 if(!$dir || !-d $dir)
1447 warn "No directory given, using ./\n";
1450 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1451 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1452 $version ||= $schema->VERSION || '1.x';
1453 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1455 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
1456 . $self->_check_sqlt_message . q{'})
1457 if !$self->_check_sqlt_version;
1459 my $sqlt = SQL::Translator->new( $sqltargs );
1461 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1462 my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
1464 foreach my $db (@$databases)
1467 $sqlt = $self->configure_sqlt($sqlt, $db);
1468 $sqlt->{schema} = $sqlt_schema;
1469 $sqlt->producer($db);
1472 my $filename = $schema->ddl_filename($db, $dir, $version);
1475 warn("$filename already exists, skipping $db");
1476 next unless ($preversion);
1478 my $output = $sqlt->translate;
1481 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1484 if(!open($file, ">$filename"))
1486 $self->throw_exception("Can't open $filename for writing ($!)");
1489 print $file $output;
1494 require SQL::Translator::Diff;
1496 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1497 # print "Previous version $prefilename\n";
1498 if(!-e $prefilename)
1500 warn("No previous schema file found ($prefilename)");
1504 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1505 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1508 warn("$difffile already exists, skipping");
1514 my $t = SQL::Translator->new($sqltargs);
1517 $t->parser( $db ) or die $t->error;
1518 $t = $self->configure_sqlt($t, $db);
1519 my $out = $t->translate( $prefilename ) or die $t->error;
1520 $source_schema = $t->schema;
1521 unless ( $source_schema->name ) {
1522 $source_schema->name( $prefilename );
1526 # The "new" style of producers have sane normalization and can support
1527 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
1528 # And we have to diff parsed SQL against parsed SQL.
1529 my $dest_schema = $sqlt_schema;
1531 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
1532 my $t = SQL::Translator->new($sqltargs);
1535 $t->parser( $db ) or die $t->error;
1536 $t = $self->configure_sqlt($t, $db);
1537 my $out = $t->translate( $filename ) or die $t->error;
1538 $dest_schema = $t->schema;
1539 $dest_schema->name( $filename )
1540 unless $dest_schema->name;
1544 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1548 if(!open $file, ">$difffile")
1550 $self->throw_exception("Can't write to $difffile ($!)");
1559 sub configure_sqlt() {
1562 my $db = shift || $self->sqlt_type;
1563 if ($db eq 'PostgreSQL') {
1564 $tr->quote_table_names(0);
1565 $tr->quote_field_names(0);
1570 =head2 deployment_statements
1574 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1578 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1579 The database driver name is given by C<$type>, though the value from
1580 L</sqlt_type> is used if it is not specified.
1582 C<$directory> is used to return statements from files in a previously created
1583 L</create_ddl_dir> directory and is optional. The filenames are constructed
1584 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1586 If no C<$directory> is specified then the statements are constructed on the
1587 fly using L<SQL::Translator> and C<$version> is ignored.
1589 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1593 sub deployment_statements {
1594 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1595 # Need to be connected to get the correct sqlt_type
1596 $self->ensure_connected() unless $type;
1597 $type ||= $self->sqlt_type;
1598 $version ||= $schema->VERSION || '1.x';
1600 my $filename = $schema->ddl_filename($type, $dir, $version);
1604 open($file, "<$filename")
1605 or $self->throw_exception("Can't open $filename ($!)");
1608 return join('', @rows);
1611 $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
1612 . $self->_check_sqlt_message . q{'})
1613 if !$self->_check_sqlt_version;
1615 require SQL::Translator::Parser::DBIx::Class;
1616 eval qq{use SQL::Translator::Producer::${type}};
1617 $self->throw_exception($@) if $@;
1619 # sources needs to be a parser arg, but for simplicty allow at top level
1621 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1622 if exists $sqltargs->{sources};
1624 my $tr = SQL::Translator->new(%$sqltargs);
1625 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1626 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1633 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1634 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1635 foreach my $line ( split(";\n", $statement)) {
1636 next if($line =~ /^--/);
1638 # next if($line =~ /^DROP/m);
1639 next if($line =~ /^BEGIN TRANSACTION/m);
1640 next if($line =~ /^COMMIT/m);
1641 next if $line =~ /^\s+$/; # skip whitespace only
1642 $self->_query_start($line);
1644 $self->dbh->do($line); # shouldn't be using ->dbh ?
1647 warn qq{$@ (running "${line}")};
1649 $self->_query_end($line);
1654 =head2 datetime_parser
1656 Returns the datetime parser class
1660 sub datetime_parser {
1662 return $self->{datetime_parser} ||= do {
1663 $self->ensure_connected;
1664 $self->build_datetime_parser(@_);
1668 =head2 datetime_parser_type
1670 Defines (returns) the datetime parser class - currently hardwired to
1671 L<DateTime::Format::MySQL>
1675 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1677 =head2 build_datetime_parser
1679 See L</datetime_parser>
1683 sub build_datetime_parser {
1685 my $type = $self->datetime_parser_type(@_);
1687 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1692 my $_check_sqlt_version; # private
1693 my $_check_sqlt_message; # private
1694 sub _check_sqlt_version {
1695 return $_check_sqlt_version if defined $_check_sqlt_version;
1696 eval 'use SQL::Translator "0.09"';
1697 $_check_sqlt_message = $@ || '';
1698 $_check_sqlt_version = !$@;
1701 sub _check_sqlt_message {
1702 _check_sqlt_version if !defined $_check_sqlt_message;
1703 $_check_sqlt_message;
1709 return if !$self->_dbh;
1718 The module defines a set of methods within the DBIC::SQL::Abstract
1719 namespace. These build on L<SQL::Abstract::Limit> to provide the
1720 SQL query functions.
1722 The following methods are extended:-
1736 See L</connect_info> for details.
1737 For setting, this method is deprecated in favor of L</connect_info>.
1741 See L</connect_info> for details.
1742 For setting, this method is deprecated in favor of L</connect_info>.
1746 See L</connect_info> for details.
1747 For setting, this method is deprecated in favor of L</connect_info>.
1753 Matt S. Trout <mst@shadowcatsystems.co.uk>
1755 Andy Grundman <andy@hybridized.org>
1759 You may distribute this code under the same terms as Perl itself.