Massive cleanup of transaction handlers
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm
index c26525d..29fc1bf 100644 (file)
@@ -7,7 +7,7 @@ use warnings;
 use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/;
 use mro 'c3';
 
-use Carp::Clan qw/^DBIx::Class/;
+use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
 use DBI;
 use DBIx::Class::Storage::DBI::Cursor;
 use DBIx::Class::Storage::Statistics;
@@ -18,12 +18,12 @@ use Try::Tiny;
 use File::Path 'make_path';
 use namespace::clean;
 
+
 # default cursor class, overridable in connect_info attributes
 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
 
-__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
-# default
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
+__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class sql_limit_dialect/);
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker');
 
 __PACKAGE__->mk_group_accessors('simple' => qw/
   _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
@@ -72,7 +72,6 @@ my @rdbms_specific_methods = qw/
   build_datetime_parser
   datetime_parser_type
 
-
   insert
   insert_bulk
   update
@@ -82,6 +81,9 @@ my @rdbms_specific_methods = qw/
 
   get_use_dbms_capability
   get_dbms_capability
+
+  _server_info
+  _get_server_version
 /;
 
 for my $meth (@rdbms_specific_methods) {
@@ -94,9 +96,15 @@ for my $meth (@rdbms_specific_methods) {
   *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
     if (not $_[0]->_driver_determined and not $_[0]->{_in_determine_driver}) {
       $_[0]->_determine_driver;
-      goto $_[0]->can($meth);
+
+      # This for some reason crashes and burns on perl 5.8.1
+      # IFF the method ends up throwing an exception
+      #goto $_[0]->can ($meth);
+
+      my $cref = $_[0]->can ($meth);
+      goto $cref;
     }
-    $orig->(@_);
+    goto $orig;
   };
 }
 
@@ -179,17 +187,8 @@ sub new {
 sub DESTROY {
   my $self = shift;
 
-  # destroy just the object if not native to this process/thread
-  $self->_preserve_foreign_dbh;
-
-  # some databases need this to stop spewing warnings
-  if (my $dbh = $self->_dbh) {
-    try {
-      %{ $dbh->{CachedKids} } = ();
-      $dbh->disconnect;
-    };
-  }
-
+  # some databases spew warnings on implicit disconnect
+  local $SIG{__WARN__} = sub {};
   $self->_dbh(undef);
 }
 
@@ -448,14 +447,13 @@ statement handles via L<DBI/prepare_cached>.
 
 =item limit_dialect
 
-Sets the limit dialect. This is useful for JDBC-bridge among others
-where the remote SQL-dialect cannot be determined by the name of the
-driver alone. See also L<SQL::Abstract::Limit>.
+Sets a specific SQL::Abstract::Limit-style limit dialect, overriding the
+default L</sql_limit_dialect> setting of the storage (if any). For a list
+of available limit dialects see L<DBIx::Class::SQLMaker::LimitDialects>.
 
 =item quote_char
 
-Specifies what characters to use to quote table and column names. If
-you use this you will want to specify L</name_sep> as well.
+Specifies what characters to use to quote table and column names.
 
 C<quote_char> expects either a single character, in which case is it
 is placed on either side of the table/column name, or an arrayref of length
@@ -466,14 +464,9 @@ SQL Server you should use C<< quote_char => [qw/[ ]/] >>.
 
 =item name_sep
 
-This only needs to be used in conjunction with C<quote_char>, and is used to
+This parameter is only useful in conjunction with C<quote_char>, and is used to
 specify the character that separates elements (schemas, tables, columns) from
-each other. In most cases this is simply a C<.>.
-
-The consequences of not supplying this value is that L<SQL::Abstract>
-will assume DBIx::Class' uses of aliases to be complete column
-names. The output will look like I<"me.name"> when it should actually
-be I<"me"."name">.
+each other. If unspecified it defaults to the most commonly used C<.>.
 
 =item unsafe
 
@@ -526,7 +519,7 @@ L<DBIx::Class::Schema/connect>
       'postgres',
       'my_pg_password',
       { AutoCommit => 1 },
-      { quote_char => q{"}, name_sep => q{.} },
+      { quote_char => q{"} },
     ]
   );
 
@@ -785,8 +778,6 @@ sub txn_do {
   ref $coderef eq 'CODE' or $self->throw_exception
     ('$coderef must be a CODE reference');
 
-  return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
-
   local $self->{_in_dbh_do} = 1;
 
   my @result;
@@ -800,9 +791,8 @@ sub txn_do {
     my $args = \@_;
 
     try {
-      $self->_get_dbh;
-
       $self->txn_begin;
+      my $txn_start_depth = $self->transaction_depth;
       if($want_array) {
           @result = $coderef->(@$args);
       }
@@ -812,14 +802,22 @@ sub txn_do {
       else {
           $coderef->(@$args);
       }
-      $self->txn_commit;
+
+      my $delta_txn = $txn_start_depth - $self->transaction_depth;
+      if ($delta_txn == 0) {
+        $self->txn_commit;
+      }
+      elsif ($delta_txn != 1) {
+        # an off-by-one would mean we fired a rollback
+        carp "Unexpected reduction of transaction depth by $delta_txn after execution of $coderef";
+      }
     } catch {
       $exception = $_;
     };
 
     if(! defined $exception) { return $want_array ? @result : $result[0] }
 
-    if($tried++ || $self->connected) {
+    if($self->transaction_depth > 1 || $tried++ || $self->connected) {
       my $rollback_exception;
       try { $self->txn_rollback } catch { $rollback_exception = shift };
       if(defined $rollback_exception) {
@@ -838,7 +836,7 @@ sub txn_do {
     # We were not connected, and was first try - reconnect and retry
     # via the while loop
     carp "Retrying $coderef after catching disconnected exception: $exception"
-      if $ENV{DBIC_DBIRETRY_DEBUG};
+      if $ENV{DBIC_TXNRETRY_DEBUG};
     $self->_populate_dbh;
   }
 }
@@ -973,23 +971,38 @@ sub _get_dbh {
   return $self->_dbh;
 }
 
-sub _sql_maker_args {
-    my ($self) = @_;
-
-    return (
-      bindtype=>'columns',
-      array_datatypes => 1,
-      limit_dialect => $self->_get_dbh,
-      %{$self->_sql_maker_opts}
-    );
-}
-
 sub sql_maker {
   my ($self) = @_;
   unless ($self->_sql_maker) {
     my $sql_maker_class = $self->sql_maker_class;
     $self->ensure_class_loaded ($sql_maker_class);
-    $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
+
+    my %opts = %{$self->_sql_maker_opts||{}};
+    my $dialect =
+      $opts{limit_dialect}
+        ||
+      $self->sql_limit_dialect
+        ||
+      do {
+        my $s_class = (ref $self) || $self;
+        carp (
+          "Your storage class ($s_class) does not set sql_limit_dialect and you "
+        . 'have not supplied an explicit limit_dialect in your connection_info. '
+        . 'DBIC will attempt to use the GenericSubQ dialect, which works on most '
+        . 'databases but can be (and often is) painfully slow.'
+        );
+
+        'GenericSubQ';
+      }
+    ;
+
+    $self->_sql_maker($sql_maker_class->new(
+      bindtype=>'columns',
+      array_datatypes => 1,
+      limit_dialect => $dialect,
+      name_sep => '.',
+      %opts,
+    ));
   }
   return $self->_sql_maker;
 }
@@ -1362,9 +1375,8 @@ sub svp_rollback {
 }
 
 sub _svp_generate_name {
-    my ($self) = @_;
-
-    return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
+  my ($self) = @_;
+  return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
 }
 
 sub txn_begin {
@@ -1372,9 +1384,18 @@ sub txn_begin {
 
   # this means we have not yet connected and do not know the AC status
   # (e.g. coderef $dbh)
-  $self->ensure_connected if (! defined $self->_dbh_autocommit);
+  if (! defined $self->_dbh_autocommit) {
+    $self->ensure_connected;
+  }
+  # otherwise re-connect on pid changes, so
+  # that the txn_depth is adjusted properly
+  # the lightweight _get_dbh is good enoug here
+  # (only superficial handle check, no pings)
+  else {
+    $self->_get_dbh;
+  }
 
-  if($self->{transaction_depth} == 0) {
+  if($self->transaction_depth == 0) {
     $self->debugobj->txn_begin()
       if $self->debug;
     $self->_dbh_begin_work;
@@ -1414,6 +1435,9 @@ sub txn_commit {
     $self->svp_release
       if $self->auto_savepoint;
   }
+  else {
+    $self->throw_exception( 'Refusing to commit without a started transaction' );
+  }
 }
 
 sub _dbh_commit {
@@ -1759,15 +1783,14 @@ sub _execute_array {
   }
   catch {
     $err = shift;
+  };
+
+  # Statement must finish even if there was an exception.
+  try {
+    $sth->finish
   }
-  finally {
-    # Statement must finish even if there was an exception.
-    try {
-      $sth->finish
-    }
-    catch {
-      $err = shift unless defined $err
-    };
+  catch {
+    $err = shift unless defined $err
   };
 
   $err = $sth->errstr
@@ -2005,12 +2028,19 @@ sub _select_args {
     }
   }
 
-  # adjust limits
+  # Sanity check the attributes (SQLMaker does it too, but
+  # in case of a software_limit we'll never reach there)
+  if (defined $attrs->{offset}) {
+    $self->throw_exception('A supplied offset attribute must be a non-negative integer')
+      if ( $attrs->{offset} =~ /\D/ or $attrs->{offset} < 0 );
+  }
+  $attrs->{offset} ||= 0;
+
   if (defined $attrs->{rows}) {
-    $self->throw_exception("rows attribute must be positive if present")
-      unless $attrs->{rows} > 0;
+    $self->throw_exception("The rows attribute must be a positive integer if present")
+      if ( $attrs->{rows} =~ /\D/ or $attrs->{rows} <= 0 );
   }
-  elsif (defined $attrs->{offset}) {
+  elsif ($attrs->{offset}) {
     # MySQL actually recommends this approach.  I cringe.
     $attrs->{rows} = $sql_maker->__max_int;
   }
@@ -2111,6 +2141,13 @@ sub select_single {
   return @row;
 }
 
+=head2 sql_limit_dialect
+
+This is an accessor for the default SQL limit dialect used by a particular
+storage driver. Can be overriden by supplying an explicit L</limit_dialect>
+to L<DBIx::Class::Schema/connect>. For a list of available limit dialects
+see L<DBIx::Class::SQLMaker::LimitDialects>.
+
 =head2 sth
 
 =over 4