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 transaction_depth _dbh_autocommit savepoints/
20 # the values for these accessors are picked out (and deleted) from
21 # the attribute hashref passed to connect_info
22 my @storage_options = qw/
23 on_connect_do on_disconnect_do disable_sth_caching unsafe auto_savepoint
25 __PACKAGE__->mk_group_accessors('simple' => @storage_options);
28 # default cursor class, overridable in connect_info attributes
29 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
31 __PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
32 __PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
36 package # Hide from PAUSE
37 DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
39 use base qw/SQL::Abstract::Limit/;
41 # This prevents the caching of $dbh in S::A::L, I believe
43 my $self = shift->SUPER::new(@_);
45 # If limit_dialect is a ref (like a $dbh), go ahead and replace
46 # it with what it resolves to:
47 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
48 if ref $self->{limit_dialect};
53 # While we're at it, this should make LIMIT queries more efficient,
54 # without digging into things too deeply
55 use Scalar::Util 'blessed';
57 my ($self, $syntax) = @_;
58 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
59 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
60 return 'RowNumberOver';
63 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
67 my ($self, $table, $fields, $where, $order, @rest) = @_;
68 $table = $self->_quote($table) unless ref($table);
69 local $self->{rownum_hack_count} = 1
70 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
71 @rest = (-1) unless defined $rest[0];
72 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
73 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
74 local $self->{having_bind} = [];
75 my ($sql, @ret) = $self->SUPER::select(
76 $table, $self->_recurse_fields($fields), $where, $order, @rest
81 $self->{for} eq 'update' ? ' FOR UPDATE' :
82 $self->{for} eq 'shared' ? ' FOR SHARE' :
87 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
93 $table = $self->_quote($table) unless ref($table);
94 $self->SUPER::insert($table, @_);
100 $table = $self->_quote($table) unless ref($table);
101 $self->SUPER::update($table, @_);
107 $table = $self->_quote($table) unless ref($table);
108 $self->SUPER::delete($table, @_);
114 return $_[1].$self->_order_by($_[2]);
116 return $self->SUPER::_emulate_limit(@_);
120 sub _recurse_fields {
121 my ($self, $fields, $params) = @_;
122 my $ref = ref $fields;
123 return $self->_quote($fields) unless $ref;
124 return $$fields if $ref eq 'SCALAR';
126 if ($ref eq 'ARRAY') {
127 return join(', ', map {
128 $self->_recurse_fields($_)
129 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
130 ? ' AS col'.$self->{rownum_hack_count}++
133 } elsif ($ref eq 'HASH') {
134 foreach my $func (keys %$fields) {
135 return $self->_sqlcase($func)
136 .'( '.$self->_recurse_fields($fields->{$func}).' )';
145 if (ref $_[0] eq 'HASH') {
146 if (defined $_[0]->{group_by}) {
147 $ret = $self->_sqlcase(' group by ')
148 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
150 if (defined $_[0]->{having}) {
152 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
153 push(@{$self->{having_bind}}, @extra);
154 $ret .= $self->_sqlcase(' having ').$frag;
156 if (defined $_[0]->{order_by}) {
157 $ret .= $self->_order_by($_[0]->{order_by});
159 if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
160 return $self->SUPER::_order_by($_[0]);
162 } elsif (ref $_[0] eq 'SCALAR') {
163 $ret = $self->_sqlcase(' order by ').${ $_[0] };
164 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
165 my @order = @{+shift};
166 $ret = $self->_sqlcase(' order by ')
168 my $r = $self->_order_by($_, @_);
169 $r =~ s/^ ?ORDER BY //i;
173 $ret = $self->SUPER::_order_by(@_);
178 sub _order_directions {
179 my ($self, $order) = @_;
180 $order = $order->{order_by} if ref $order eq 'HASH';
181 return $self->SUPER::_order_directions($order);
185 my ($self, $from) = @_;
186 if (ref $from eq 'ARRAY') {
187 return $self->_recurse_from(@$from);
188 } elsif (ref $from eq 'HASH') {
189 return $self->_make_as($from);
191 return $from; # would love to quote here but _table ends up getting called
192 # twice during an ->select without a limit clause due to
193 # the way S::A::Limit->select works. should maybe consider
194 # bypassing this and doing S::A::select($self, ...) in
195 # our select method above. meantime, quoting shims have
196 # been added to select/insert/update/delete here
201 my ($self, $from, @join) = @_;
203 push(@sqlf, $self->_make_as($from));
204 foreach my $j (@join) {
207 # check whether a join type exists
208 my $join_clause = '';
209 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
210 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
211 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
213 $join_clause = ' JOIN ';
215 push(@sqlf, $join_clause);
217 if (ref $to eq 'ARRAY') {
218 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
220 push(@sqlf, $self->_make_as($to));
222 push(@sqlf, ' ON (', $self->_join_condition($on), ')');
224 return join('', @sqlf);
228 my ($self, $from) = @_;
229 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
230 reverse each %{$self->_skip_options($from)});
234 my ($self, $hash) = @_;
236 $clean_hash->{$_} = $hash->{$_}
237 for grep {!/^-/} keys %$hash;
241 sub _join_condition {
242 my ($self, $cond) = @_;
243 if (ref $cond eq 'HASH') {
248 # XXX no throw_exception() in this package and croak() fails with strange results
249 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
250 if ref($v) ne 'SCALAR';
254 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
257 return scalar($self->_recurse_where(\%j));
258 } elsif (ref $cond eq 'ARRAY') {
259 return join(' OR ', map { $self->_join_condition($_) } @$cond);
261 die "Can't handle this yet!";
266 my ($self, $label) = @_;
267 return '' unless defined $label;
268 return "*" if $label eq '*';
269 return $label unless $self->{quote_char};
270 if(ref $self->{quote_char} eq "ARRAY"){
271 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
272 if !defined $self->{name_sep};
273 my $sep = $self->{name_sep};
274 return join($self->{name_sep},
275 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
276 split(/\Q$sep\E/,$label));
278 return $self->SUPER::_quote($label);
283 $self->{limit_dialect} = shift if @_;
284 return $self->{limit_dialect};
289 $self->{quote_char} = shift if @_;
290 return $self->{quote_char};
295 $self->{name_sep} = shift if @_;
296 return $self->{name_sep};
299 } # End of BEGIN block
303 DBIx::Class::Storage::DBI - DBI storage handler
307 my $schema = MySchema->connect('dbi:SQLite:my.db');
309 $schema->storage->debug(1);
310 $schema->dbh_do("DROP TABLE authors");
312 $schema->resultset('Book')->search({
313 written_on => $schema->storage->datetime_parser(DateTime->now)
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 This method is normally called by L<DBIx::Class::Schema/connection>, which
341 encapsulates its argument list in an arrayref before passing them here.
343 The argument list may contain:
349 The same 4-element argument set one would normally pass to
350 L<DBI/connect>, optionally followed by
351 L<extra attributes|/DBIx::Class specific connection attributes>
352 recognized by DBIx::Class:
354 $connect_info_args = [ $dsn, $user, $password, \%dbi_attributes?, \%extra_attributes? ];
358 A single code reference which returns a connected
359 L<DBI database handle|DBI/connect> optionally followed by
360 L<extra attributes|/DBIx::Class specific connection attributes> recognized
363 $connect_info_args = [ sub { DBI->connect (...) }, \%extra_attributes? ];
367 A single hashref with all the attributes and the dsn/user/password
370 $connect_info_args = [{
378 This is particularly useful for L<Catalyst> based applications, allowing the
379 following config (L<Config::General> style):
384 dsn dbi:mysql:database=test
393 Please note that the L<DBI> docs recommend that you always explicitly
394 set C<AutoCommit> to either I<0> or I<1>. L<DBIx::Class> further
395 recommends that it be set to I<1>, and that you perform transactions
396 via our L<DBIx::Class::Schema/txn_do> method. L<DBIx::Class> will set it
397 to I<1> if you do not do explicitly set it to zero. This is the default
398 for most DBDs. See L</DBIx::Class and AutoCommit> for details.
400 =head3 DBIx::Class specific connection attributes
402 In addition to the standard L<DBI|DBI/ATTRIBUTES_COMMON_TO_ALL_HANDLES>
403 L<connection|DBI/Database_Handle_Attributes> attributes, DBIx::Class recognizes
404 the following connection options. These options can be mixed in with your other
405 L<DBI> connection attributes, or placed in a seperate hashref
406 (C<\%extra_attributes>) as shown above.
408 Every time C<connect_info> is invoked, any previous settings for
409 these options will be cleared before setting the new ones, regardless of
410 whether any options are specified in the new C<connect_info>.
417 Specifies things to do immediately after connecting or re-connecting to
418 the database. Its value may contain:
422 =item an array reference
424 This contains SQL statements to execute in order. Each element contains
425 a string or a code reference that returns a string.
427 =item a code reference
429 This contains some code to execute. Unlike code references within an
430 array reference, its return value is ignored.
434 =item on_disconnect_do
436 Takes arguments in the same form as L</on_connect_do> and executes them
437 immediately before disconnecting from the database.
439 Note, this only runs if you explicitly call L</disconnect> on the
442 =item disable_sth_caching
444 If set to a true value, this option will disable the caching of
445 statement handles via L<DBI/prepare_cached>.
449 Sets the limit dialect. This is useful for JDBC-bridge among others
450 where the remote SQL-dialect cannot be determined by the name of the
451 driver alone. See also L<SQL::Abstract::Limit>.
455 Specifies what characters to use to quote table and column names. If
456 you use this you will want to specify L</name_sep> as well.
458 C<quote_char> expects either a single character, in which case is it
459 is placed on either side of the table/column name, or an arrayref of length
460 2 in which case the table/column name is placed between the elements.
462 For example under MySQL you should use C<< quote_char => '`' >>, and for
463 SQL Server you should use C<< quote_char => [qw/[ ]/] >>.
467 This only needs to be used in conjunction with C<quote_char>, and is used to
468 specify the charecter that seperates elements (schemas, tables, columns) from
469 each other. In most cases this is simply a C<.>.
471 The consequences of not supplying this value is that L<SQL::Abstract>
472 will assume DBIx::Class' uses of aliases to be complete column
473 names. The output will look like I<"me.name"> when it should actually
478 This Storage driver normally installs its own C<HandleError>, sets
479 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
480 all database handles, including those supplied by a coderef. It does this
481 so that it can have consistent and useful error behavior.
483 If you set this option to a true value, Storage will not do its usual
484 modifications to the database handle's attributes, and instead relies on
485 the settings in your connect_info DBI options (or the values you set in
486 your connection coderef, in the case that you are connecting via coderef).
488 Note that your custom settings can cause Storage to malfunction,
489 especially if you set a C<HandleError> handler that suppresses exceptions
490 and/or disable C<RaiseError>.
494 If this option is true, L<DBIx::Class> will use savepoints when nesting
495 transactions, making it possible to recover from failure in the inner
496 transaction without having to abort all outer transactions.
500 Use this argument to supply a cursor class other than the default
501 L<DBIx::Class::Storage::DBI::Cursor>.
505 Some real-life examples of arguments to L</connect_info> and
506 L<DBIx::Class::Schema/connect>
508 # Simple SQLite connection
509 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
512 ->connect_info([ sub { DBI->connect(...) } ]);
514 # A bit more complicated
521 { quote_char => q{"}, name_sep => q{.} },
525 # Equivalent to the previous example
531 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
535 # Same, but with hashref as argument
536 # See parse_connect_info for explanation
539 dsn => 'dbi:Pg:dbname=foo',
541 password => 'my_pg_password',
548 # Subref + DBIx::Class-specific connection options
551 sub { DBI->connect(...) },
555 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
556 disable_sth_caching => 1,
566 my ($self, $info_arg) = @_;
568 return $self->_connect_info if !$info_arg;
570 my @args = @$info_arg; # take a shallow copy for further mutilation
571 $self->_connect_info([@args]); # copy for _connect_info
574 # combine/pre-parse arguments depending on invocation style
577 if (ref $args[0] eq 'CODE') { # coderef with optional \%extra_attributes
578 %attrs = %{ $args[1] || {} };
581 elsif (ref $args[0] eq 'HASH') { # single hashref (i.e. Catalyst config)
582 %attrs = %{$args[0]};
584 for (qw/password user dsn/) {
585 unshift @args, delete $attrs{$_};
588 else { # otherwise assume dsn/user/password + \%attrs + \%extra_attrs
590 % { $args[3] || {} },
591 % { $args[4] || {} },
593 @args = @args[0,1,2];
596 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
597 # the new set of options
598 $self->_sql_maker(undef);
599 $self->_sql_maker_opts({});
602 for my $storage_opt (@storage_options, 'cursor_class') { # @storage_options is declared at the top of the module
603 if(my $value = delete $attrs{$storage_opt}) {
604 $self->$storage_opt($value);
607 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
608 if(my $opt_val = delete $attrs{$sql_maker_opt}) {
609 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
614 %attrs = () if (ref $args[0] eq 'CODE'); # _connect() never looks past $args[0] in this case
616 $self->_dbi_connect_info([@args, keys %attrs ? \%attrs : ()]);
617 $self->_connect_info;
622 This method is deprecated in favour of setting via L</connect_info>.
627 Arguments: ($subref | $method_name), @extra_coderef_args?
629 Execute the given $subref or $method_name using the new exception-based
630 connection management.
632 The first two arguments will be the storage object that C<dbh_do> was called
633 on and a database handle to use. Any additional arguments will be passed
634 verbatim to the called subref as arguments 2 and onwards.
636 Using this (instead of $self->_dbh or $self->dbh) ensures correct
637 exception handling and reconnection (or failover in future subclasses).
639 Your subref should have no side-effects outside of the database, as
640 there is the potential for your subref to be partially double-executed
641 if the database connection was stale/dysfunctional.
645 my @stuff = $schema->storage->dbh_do(
647 my ($storage, $dbh, @cols) = @_;
648 my $cols = join(q{, }, @cols);
649 $dbh->selectrow_array("SELECT $cols FROM foo");
660 my $dbh = $self->_dbh;
662 return $self->$code($dbh, @_) if $self->{_in_dbh_do}
663 || $self->{transaction_depth};
665 local $self->{_in_dbh_do} = 1;
668 my $want_array = wantarray;
671 $self->_verify_pid if $dbh;
673 $self->_populate_dbh;
678 @result = $self->$code($dbh, @_);
680 elsif(defined $want_array) {
681 $result[0] = $self->$code($dbh, @_);
684 $self->$code($dbh, @_);
689 if(!$exception) { return $want_array ? @result : $result[0] }
691 $self->throw_exception($exception) if $self->connected;
693 # We were not connected - reconnect and retry, but let any
694 # exception fall right through this time
695 $self->_populate_dbh;
696 $self->$code($self->_dbh, @_);
699 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
700 # It also informs dbh_do to bypass itself while under the direction of txn_do,
701 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
706 ref $coderef eq 'CODE' or $self->throw_exception
707 ('$coderef must be a CODE reference');
709 return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
711 local $self->{_in_dbh_do} = 1;
714 my $want_array = wantarray;
719 $self->_verify_pid if $self->_dbh;
720 $self->_populate_dbh if !$self->_dbh;
724 @result = $coderef->(@_);
726 elsif(defined $want_array) {
727 $result[0] = $coderef->(@_);
736 if(!$exception) { return $want_array ? @result : $result[0] }
738 if($tried++ > 0 || $self->connected) {
739 eval { $self->txn_rollback };
740 my $rollback_exception = $@;
741 if($rollback_exception) {
742 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
743 $self->throw_exception($exception) # propagate nested rollback
744 if $rollback_exception =~ /$exception_class/;
746 $self->throw_exception(
747 "Transaction aborted: ${exception}. "
748 . "Rollback failed: ${rollback_exception}"
751 $self->throw_exception($exception)
754 # We were not connected, and was first try - reconnect and retry
756 $self->_populate_dbh;
762 Our C<disconnect> method also performs a rollback first if the
763 database is not in C<AutoCommit> mode.
770 if( $self->connected ) {
771 my $connection_do = $self->on_disconnect_do;
772 $self->_do_connection_actions($connection_do) if ref($connection_do);
774 $self->_dbh->rollback unless $self->_dbh_autocommit;
775 $self->_dbh->disconnect;
781 =head2 with_deferred_fk_checks
785 =item Arguments: C<$coderef>
787 =item Return Value: The return value of $coderef
791 Storage specific method to run the code ref with FK checks deferred or
792 in MySQL's case disabled entirely.
796 # Storage subclasses should override this
797 sub with_deferred_fk_checks {
798 my ($self, $sub) = @_;
806 if(my $dbh = $self->_dbh) {
807 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
814 return 0 if !$self->_dbh;
816 return ($dbh->FETCH('Active') && $dbh->ping);
822 # handle pid changes correctly
823 # NOTE: assumes $self->_dbh is a valid $dbh
827 return if defined $self->_conn_pid && $self->_conn_pid == $$;
829 $self->_dbh->{InactiveDestroy} = 1;
836 sub ensure_connected {
839 unless ($self->connected) {
840 $self->_populate_dbh;
846 Returns the dbh - a data base handle of class L<DBI>.
853 $self->ensure_connected;
857 sub _sql_maker_args {
860 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
865 unless ($self->_sql_maker) {
866 my $sql_maker_class = $self->sql_maker_class;
867 $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
869 return $self->_sql_maker;
876 my @info = @{$self->_dbi_connect_info || []};
877 $self->_dbh($self->_connect(@info));
879 # Always set the transaction depth on connect, since
880 # there is no transaction in progress by definition
881 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
883 if(ref $self eq 'DBIx::Class::Storage::DBI') {
884 my $driver = $self->_dbh->{Driver}->{Name};
885 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
886 bless $self, "DBIx::Class::Storage::DBI::${driver}";
891 my $connection_do = $self->on_connect_do;
892 $self->_do_connection_actions($connection_do) if ref($connection_do);
894 $self->_conn_pid($$);
895 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
898 sub _do_connection_actions {
900 my $connection_do = shift;
902 if (ref $connection_do eq 'ARRAY') {
903 $self->_do_query($_) foreach @$connection_do;
905 elsif (ref $connection_do eq 'CODE') {
913 my ($self, $action) = @_;
915 if (ref $action eq 'CODE') {
916 $action = $action->($self);
917 $self->_do_query($_) foreach @$action;
920 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
921 $self->_query_start(@to_run);
922 $self->_dbh->do(@to_run);
923 $self->_query_end(@to_run);
930 my ($self, @info) = @_;
932 $self->throw_exception("You failed to provide any connection info")
935 my ($old_connect_via, $dbh);
937 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
938 $old_connect_via = $DBI::connect_via;
939 $DBI::connect_via = 'connect';
943 if(ref $info[0] eq 'CODE') {
947 $dbh = DBI->connect(@info);
950 if($dbh && !$self->unsafe) {
951 my $weak_self = $self;
953 $dbh->{HandleError} = sub {
955 $weak_self->throw_exception("DBI Exception: $_[0]");
958 croak ("DBI Exception: $_[0]");
961 $dbh->{ShowErrorStatement} = 1;
962 $dbh->{RaiseError} = 1;
963 $dbh->{PrintError} = 0;
967 $DBI::connect_via = $old_connect_via if $old_connect_via;
969 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
972 $self->_dbh_autocommit($dbh->{AutoCommit});
978 my ($self, $name) = @_;
980 $name = $self->_svp_generate_name
981 unless defined $name;
983 $self->throw_exception ("You can't use savepoints outside a transaction")
984 if $self->{transaction_depth} == 0;
986 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
987 unless $self->can('_svp_begin');
989 push @{ $self->{savepoints} }, $name;
991 $self->debugobj->svp_begin($name) if $self->debug;
993 return $self->_svp_begin($name);
997 my ($self, $name) = @_;
999 $self->throw_exception ("You can't use savepoints outside a transaction")
1000 if $self->{transaction_depth} == 0;
1002 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
1003 unless $self->can('_svp_release');
1005 if (defined $name) {
1006 $self->throw_exception ("Savepoint '$name' does not exist")
1007 unless grep { $_ eq $name } @{ $self->{savepoints} };
1009 # Dig through the stack until we find the one we are releasing. This keeps
1010 # the stack up to date.
1013 do { $svp = pop @{ $self->{savepoints} } } while $svp ne $name;
1015 $name = pop @{ $self->{savepoints} };
1018 $self->debugobj->svp_release($name) if $self->debug;
1020 return $self->_svp_release($name);
1024 my ($self, $name) = @_;
1026 $self->throw_exception ("You can't use savepoints outside a transaction")
1027 if $self->{transaction_depth} == 0;
1029 $self->throw_exception ("Your Storage implementation doesn't support savepoints")
1030 unless $self->can('_svp_rollback');
1032 if (defined $name) {
1033 # If they passed us a name, verify that it exists in the stack
1034 unless(grep({ $_ eq $name } @{ $self->{savepoints} })) {
1035 $self->throw_exception("Savepoint '$name' does not exist!");
1038 # Dig through the stack until we find the one we are releasing. This keeps
1039 # the stack up to date.
1040 while(my $s = pop(@{ $self->{savepoints} })) {
1041 last if($s eq $name);
1043 # Add the savepoint back to the stack, as a rollback doesn't remove the
1044 # named savepoint, only everything after it.
1045 push(@{ $self->{savepoints} }, $name);
1047 # We'll assume they want to rollback to the last savepoint
1048 $name = $self->{savepoints}->[-1];
1051 $self->debugobj->svp_rollback($name) if $self->debug;
1053 return $self->_svp_rollback($name);
1056 sub _svp_generate_name {
1059 return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
1064 $self->ensure_connected();
1065 if($self->{transaction_depth} == 0) {
1066 $self->debugobj->txn_begin()
1068 # this isn't ->_dbh-> because
1069 # we should reconnect on begin_work
1070 # for AutoCommit users
1071 $self->dbh->begin_work;
1072 } elsif ($self->auto_savepoint) {
1075 $self->{transaction_depth}++;
1080 if ($self->{transaction_depth} == 1) {
1081 my $dbh = $self->_dbh;
1082 $self->debugobj->txn_commit()
1085 $self->{transaction_depth} = 0
1086 if $self->_dbh_autocommit;
1088 elsif($self->{transaction_depth} > 1) {
1089 $self->{transaction_depth}--;
1091 if $self->auto_savepoint;
1097 my $dbh = $self->_dbh;
1099 if ($self->{transaction_depth} == 1) {
1100 $self->debugobj->txn_rollback()
1102 $self->{transaction_depth} = 0
1103 if $self->_dbh_autocommit;
1106 elsif($self->{transaction_depth} > 1) {
1107 $self->{transaction_depth}--;
1108 if ($self->auto_savepoint) {
1109 $self->svp_rollback;
1114 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
1119 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
1120 $error =~ /$exception_class/ and $self->throw_exception($error);
1121 # ensure that a failed rollback resets the transaction depth
1122 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
1123 $self->throw_exception($error);
1127 # This used to be the top-half of _execute. It was split out to make it
1128 # easier to override in NoBindVars without duping the rest. It takes up
1129 # all of _execute's args, and emits $sql, @bind.
1130 sub _prep_for_execute {
1131 my ($self, $op, $extra_bind, $ident, $args) = @_;
1133 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
1135 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
1138 return ($sql, \@bind);
1141 sub _fix_bind_params {
1142 my ($self, @bind) = @_;
1144 ### Turn @bind from something like this:
1145 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
1147 ### ( "'1'", "'1'", "'3'" )
1150 if ( defined( $_ && $_->[1] ) ) {
1151 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
1158 my ( $self, $sql, @bind ) = @_;
1160 if ( $self->debug ) {
1161 @bind = $self->_fix_bind_params(@bind);
1163 $self->debugobj->query_start( $sql, @bind );
1168 my ( $self, $sql, @bind ) = @_;
1170 if ( $self->debug ) {
1171 @bind = $self->_fix_bind_params(@bind);
1172 $self->debugobj->query_end( $sql, @bind );
1177 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
1179 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
1180 $ident = $ident->from();
1183 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
1185 $self->_query_start( $sql, @$bind );
1187 my $sth = $self->sth($sql,$op);
1189 my $placeholder_index = 1;
1191 foreach my $bound (@$bind) {
1192 my $attributes = {};
1193 my($column_name, @data) = @$bound;
1195 if ($bind_attributes) {
1196 $attributes = $bind_attributes->{$column_name}
1197 if defined $bind_attributes->{$column_name};
1200 foreach my $data (@data) {
1201 $data = ref $data ? ''.$data : $data; # stringify args
1203 $sth->bind_param($placeholder_index, $data, $attributes);
1204 $placeholder_index++;
1208 # Can this fail without throwing an exception anyways???
1209 my $rv = $sth->execute();
1210 $self->throw_exception($sth->errstr) if !$rv;
1212 $self->_query_end( $sql, @$bind );
1214 return (wantarray ? ($rv, $sth, @$bind) : $rv);
1219 $self->dbh_do('_dbh_execute', @_)
1223 my ($self, $source, $to_insert) = @_;
1225 my $ident = $source->from;
1226 my $bind_attributes = $self->source_bind_attributes($source);
1228 $self->ensure_connected;
1229 foreach my $col ( $source->columns ) {
1230 if ( !defined $to_insert->{$col} ) {
1231 my $col_info = $source->column_info($col);
1233 if ( $col_info->{auto_nextval} ) {
1234 $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
1239 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1244 ## Still not quite perfect, and EXPERIMENTAL
1245 ## Currently it is assumed that all values passed will be "normal", i.e. not
1246 ## scalar refs, or at least, all the same type as the first set, the statement is
1247 ## only prepped once.
1249 my ($self, $source, $cols, $data) = @_;
1251 my $table = $source->from;
1252 @colvalues{@$cols} = (0..$#$cols);
1253 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
1255 $self->_query_start( $sql, @bind );
1256 my $sth = $self->sth($sql);
1258 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1260 ## This must be an arrayref, else nothing works!
1262 my $tuple_status = [];
1265 ##print STDERR Dumper( $data, $sql, [@bind] );
1269 ## Get the bind_attributes, if any exist
1270 my $bind_attributes = $self->source_bind_attributes($source);
1272 ## Bind the values and execute
1273 my $placeholder_index = 1;
1275 foreach my $bound (@bind) {
1277 my $attributes = {};
1278 my ($column_name, $data_index) = @$bound;
1280 if( $bind_attributes ) {
1281 $attributes = $bind_attributes->{$column_name}
1282 if defined $bind_attributes->{$column_name};
1285 my @data = map { $_->[$data_index] } @$data;
1287 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1288 $placeholder_index++;
1290 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1291 $self->throw_exception($sth->errstr) if !$rv;
1293 $self->_query_end( $sql, @bind );
1294 return (wantarray ? ($rv, $sth, @bind) : $rv);
1298 my $self = shift @_;
1299 my $source = shift @_;
1300 my $bind_attributes = $self->source_bind_attributes($source);
1302 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1307 my $self = shift @_;
1308 my $source = shift @_;
1310 my $bind_attrs = {}; ## If ever it's needed...
1312 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1316 my ($self, $ident, $select, $condition, $attrs) = @_;
1317 my $order = $attrs->{order_by};
1319 if (ref $condition eq 'SCALAR') {
1320 my $unwrap = ${$condition};
1321 if ($unwrap =~ s/ORDER BY (.*)$//i) {
1323 $condition = \$unwrap;
1327 my $for = delete $attrs->{for};
1328 my $sql_maker = $self->sql_maker;
1329 local $sql_maker->{for} = $for;
1331 if (exists $attrs->{group_by} || $attrs->{having}) {
1333 group_by => $attrs->{group_by},
1334 having => $attrs->{having},
1335 ($order ? (order_by => $order) : ())
1338 my $bind_attrs = {}; ## Future support
1339 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1340 if ($attrs->{software_limit} ||
1341 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1342 $attrs->{software_limit} = 1;
1344 $self->throw_exception("rows attribute must be positive if present")
1345 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1347 # MySQL actually recommends this approach. I cringe.
1348 $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
1349 push @args, $attrs->{rows}, $attrs->{offset};
1352 return $self->_execute(@args);
1355 sub source_bind_attributes {
1356 my ($self, $source) = @_;
1358 my $bind_attributes;
1359 foreach my $column ($source->columns) {
1361 my $data_type = $source->column_info($column)->{data_type} || '';
1362 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1366 return $bind_attributes;
1373 =item Arguments: $ident, $select, $condition, $attrs
1377 Handle a SQL select statement.
1383 my ($ident, $select, $condition, $attrs) = @_;
1384 return $self->cursor_class->new($self, \@_, $attrs);
1389 my ($rv, $sth, @bind) = $self->_select(@_);
1390 my @row = $sth->fetchrow_array;
1391 my @nextrow = $sth->fetchrow_array if @row;
1392 if(@row && @nextrow) {
1393 carp "Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single";
1395 # Need to call finish() to work round broken DBDs
1404 =item Arguments: $sql
1408 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1413 my ($self, $dbh, $sql) = @_;
1415 # 3 is the if_active parameter which avoids active sth re-use
1416 my $sth = $self->disable_sth_caching
1417 ? $dbh->prepare($sql)
1418 : $dbh->prepare_cached($sql, {}, 3);
1420 # XXX You would think RaiseError would make this impossible,
1421 # but apparently that's not true :(
1422 $self->throw_exception($dbh->errstr) if !$sth;
1428 my ($self, $sql) = @_;
1429 $self->dbh_do('_dbh_sth', $sql);
1432 sub _dbh_columns_info_for {
1433 my ($self, $dbh, $table) = @_;
1435 if ($dbh->can('column_info')) {
1438 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1439 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1441 while ( my $info = $sth->fetchrow_hashref() ){
1443 $column_info{data_type} = $info->{TYPE_NAME};
1444 $column_info{size} = $info->{COLUMN_SIZE};
1445 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1446 $column_info{default_value} = $info->{COLUMN_DEF};
1447 my $col_name = $info->{COLUMN_NAME};
1448 $col_name =~ s/^\"(.*)\"$/$1/;
1450 $result{$col_name} = \%column_info;
1453 return \%result if !$@ && scalar keys %result;
1457 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1459 my @columns = @{$sth->{NAME_lc}};
1460 for my $i ( 0 .. $#columns ){
1462 $column_info{data_type} = $sth->{TYPE}->[$i];
1463 $column_info{size} = $sth->{PRECISION}->[$i];
1464 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1466 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1467 $column_info{data_type} = $1;
1468 $column_info{size} = $2;
1471 $result{$columns[$i]} = \%column_info;
1475 foreach my $col (keys %result) {
1476 my $colinfo = $result{$col};
1477 my $type_num = $colinfo->{data_type};
1479 if(defined $type_num && $dbh->can('type_info')) {
1480 my $type_info = $dbh->type_info($type_num);
1481 $type_name = $type_info->{TYPE_NAME} if $type_info;
1482 $colinfo->{data_type} = $type_name if $type_name;
1489 sub columns_info_for {
1490 my ($self, $table) = @_;
1491 $self->dbh_do('_dbh_columns_info_for', $table);
1494 =head2 last_insert_id
1496 Return the row id of the last insert.
1500 sub _dbh_last_insert_id {
1501 my ($self, $dbh, $source, $col) = @_;
1502 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1503 $dbh->func('last_insert_rowid');
1506 sub last_insert_id {
1508 $self->dbh_do('_dbh_last_insert_id', @_);
1513 Returns the database driver name.
1517 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1519 =head2 bind_attribute_by_data_type
1521 Given a datatype from column info, returns a database specific bind
1522 attribute for C<< $dbh->bind_param($val,$attribute) >> or nothing if we will
1523 let the database planner just handle it.
1525 Generally only needed for special case column types, like bytea in postgres.
1529 sub bind_attribute_by_data_type {
1533 =head2 create_ddl_dir
1537 =item Arguments: $schema \@databases, $version, $directory, $preversion, \%sqlt_args
1541 Creates a SQL file based on the Schema, for each of the specified
1542 database types, in the given directory.
1544 By default, C<\%sqlt_args> will have
1546 { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1 }
1548 merged with the hash passed in. To disable any of those features, pass in a
1549 hashref like the following
1551 { ignore_constraint_names => 0, # ... other options }
1555 sub create_ddl_dir {
1556 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1558 if(!$dir || !-d $dir) {
1559 warn "No directory given, using ./\n";
1562 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1563 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1565 my $schema_version = $schema->schema_version || '1.x';
1566 $version ||= $schema_version;
1569 add_drop_table => 1,
1570 ignore_constraint_names => 1,
1571 ignore_index_names => 1,
1575 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
1576 . $self->_check_sqlt_message . q{'})
1577 if !$self->_check_sqlt_version;
1579 my $sqlt = SQL::Translator->new( $sqltargs );
1581 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1582 my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
1584 foreach my $db (@$databases) {
1586 $sqlt = $self->configure_sqlt($sqlt, $db);
1587 $sqlt->{schema} = $sqlt_schema;
1588 $sqlt->producer($db);
1591 my $filename = $schema->ddl_filename($db, $version, $dir);
1592 if (-e $filename && ($version eq $schema_version )) {
1593 # if we are dumping the current version, overwrite the DDL
1594 warn "Overwriting existing DDL file - $filename";
1598 my $output = $sqlt->translate;
1600 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1603 if(!open($file, ">$filename")) {
1604 $self->throw_exception("Can't open $filename for writing ($!)");
1607 print $file $output;
1610 next unless ($preversion);
1612 require SQL::Translator::Diff;
1614 my $prefilename = $schema->ddl_filename($db, $preversion, $dir);
1615 if(!-e $prefilename) {
1616 warn("No previous schema file found ($prefilename)");
1620 my $difffile = $schema->ddl_filename($db, $version, $dir, $preversion);
1622 warn("Overwriting existing diff file - $difffile");
1628 my $t = SQL::Translator->new($sqltargs);
1631 $t->parser( $db ) or die $t->error;
1632 $t = $self->configure_sqlt($t, $db);
1633 my $out = $t->translate( $prefilename ) or die $t->error;
1634 $source_schema = $t->schema;
1635 unless ( $source_schema->name ) {
1636 $source_schema->name( $prefilename );
1640 # The "new" style of producers have sane normalization and can support
1641 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
1642 # And we have to diff parsed SQL against parsed SQL.
1643 my $dest_schema = $sqlt_schema;
1645 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
1646 my $t = SQL::Translator->new($sqltargs);
1649 $t->parser( $db ) or die $t->error;
1650 $t = $self->configure_sqlt($t, $db);
1651 my $out = $t->translate( $filename ) or die $t->error;
1652 $dest_schema = $t->schema;
1653 $dest_schema->name( $filename )
1654 unless $dest_schema->name;
1657 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1661 if(!open $file, ">$difffile") {
1662 $self->throw_exception("Can't write to $difffile ($!)");
1670 sub configure_sqlt() {
1673 my $db = shift || $self->sqlt_type;
1674 if ($db eq 'PostgreSQL') {
1675 $tr->quote_table_names(0);
1676 $tr->quote_field_names(0);
1681 =head2 deployment_statements
1685 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1689 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1690 The database driver name is given by C<$type>, though the value from
1691 L</sqlt_type> is used if it is not specified.
1693 C<$directory> is used to return statements from files in a previously created
1694 L</create_ddl_dir> directory and is optional. The filenames are constructed
1695 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1697 If no C<$directory> is specified then the statements are constructed on the
1698 fly using L<SQL::Translator> and C<$version> is ignored.
1700 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1704 sub deployment_statements {
1705 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1706 # Need to be connected to get the correct sqlt_type
1707 $self->ensure_connected() unless $type;
1708 $type ||= $self->sqlt_type;
1709 $version ||= $schema->schema_version || '1.x';
1711 my $filename = $schema->ddl_filename($type, $dir, $version);
1715 open($file, "<$filename")
1716 or $self->throw_exception("Can't open $filename ($!)");
1719 return join('', @rows);
1722 $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
1723 . $self->_check_sqlt_message . q{'})
1724 if !$self->_check_sqlt_version;
1726 require SQL::Translator::Parser::DBIx::Class;
1727 eval qq{use SQL::Translator::Producer::${type}};
1728 $self->throw_exception($@) if $@;
1730 # sources needs to be a parser arg, but for simplicty allow at top level
1732 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1733 if exists $sqltargs->{sources};
1735 my $tr = SQL::Translator->new(%$sqltargs);
1736 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1737 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1741 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1742 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1743 foreach my $line ( split(";\n", $statement)) {
1744 next if($line =~ /^--/);
1746 # next if($line =~ /^DROP/m);
1747 next if($line =~ /^BEGIN TRANSACTION/m);
1748 next if($line =~ /^COMMIT/m);
1749 next if $line =~ /^\s+$/; # skip whitespace only
1750 $self->_query_start($line);
1752 $self->dbh->do($line); # shouldn't be using ->dbh ?
1755 warn qq{$@ (running "${line}")};
1757 $self->_query_end($line);
1762 =head2 datetime_parser
1764 Returns the datetime parser class
1768 sub datetime_parser {
1770 return $self->{datetime_parser} ||= do {
1771 $self->ensure_connected;
1772 $self->build_datetime_parser(@_);
1776 =head2 datetime_parser_type
1778 Defines (returns) the datetime parser class - currently hardwired to
1779 L<DateTime::Format::MySQL>
1783 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1785 =head2 build_datetime_parser
1787 See L</datetime_parser>
1791 sub build_datetime_parser {
1793 my $type = $self->datetime_parser_type(@_);
1795 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1800 my $_check_sqlt_version; # private
1801 my $_check_sqlt_message; # private
1802 sub _check_sqlt_version {
1803 return $_check_sqlt_version if defined $_check_sqlt_version;
1804 eval 'use SQL::Translator "0.09"';
1805 $_check_sqlt_message = $@ || '';
1806 $_check_sqlt_version = !$@;
1809 sub _check_sqlt_message {
1810 _check_sqlt_version if !defined $_check_sqlt_message;
1811 $_check_sqlt_message;
1815 =head2 is_replicating
1817 A boolean that reports if a particular L<DBIx::Class::Storage::DBI> is set to
1818 replicate from a master database. Default is undef, which is the result
1819 returned by databases that don't support replication.
1823 sub is_replicating {
1828 =head2 lag_behind_master
1830 Returns a number that represents a certain amount of lag behind a master db
1831 when a given storage is replicating. The number is database dependent, but
1832 starts at zero and increases with the amount of lag. Default in undef
1836 sub lag_behind_master {
1842 return if !$self->_dbh;
1851 =head2 DBIx::Class and AutoCommit
1853 DBIx::Class can do some wonderful magic with handling exceptions,
1854 disconnections, and transactions when you use C<< AutoCommit => 1 >>
1855 combined with C<txn_do> for transaction support.
1857 If you set C<< AutoCommit => 0 >> in your connect info, then you are always
1858 in an assumed transaction between commits, and you're telling us you'd
1859 like to manage that manually. A lot of the magic protections offered by
1860 this module will go away. We can't protect you from exceptions due to database
1861 disconnects because we don't know anything about how to restart your
1862 transactions. You're on your own for handling all sorts of exceptional
1863 cases if you choose the C<< AutoCommit => 0 >> path, just as you would
1869 The module defines a set of methods within the DBIC::SQL::Abstract
1870 namespace. These build on L<SQL::Abstract::Limit> to provide the
1871 SQL query functions.
1873 The following methods are extended:-
1887 See L</connect_info> for details.
1891 See L</connect_info> for details.
1895 See L</connect_info> for details.
1901 Matt S. Trout <mst@shadowcatsystems.co.uk>
1903 Andy Grundman <andy@hybridized.org>
1907 You may distribute this code under the same terms as Perl itself.