X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=40ae3f91cf0c07b9008a64357638d59984448a59;hb=a2c77c97735124a7bf4073cf5cef5480bec752a8;hp=f4159a2a62143cfb82eef742a5b078a23237bf71;hpb=d63c9e6418251a745cc6b6e1ef5ddf4b12ceb190;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index f4159a2..40ae3f9 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -119,12 +119,16 @@ for my $meth (keys %$storage_accessor_idx, qw(
   my $orig = __PACKAGE__->can ($meth)
     or die "$meth is not a ::Storage::DBI method!";
 
-  my $is_getter = $storage_accessor_idx->{$meth} ? 0 : 1;
+  my $possibly_a_setter = $storage_accessor_idx->{$meth} ? 1 : 0;
 
   quote_sub
-    __PACKAGE__ ."::$meth", sprintf( <<'EOC', $is_getter, perlstring $meth ), { '$orig' => \$orig };
+    __PACKAGE__ ."::$meth", sprintf( <<'EOC', $possibly_a_setter, perlstring $meth ), { '$orig' => \$orig };
 
     if (
+      # if this is an actual *setter* - just set it, no need to connect
+      # and determine the driver
+      !( %1$s and @_ > 1 )
+        and
       # only fire when invoked on an instance, a valid class-based invocation
       # would e.g. be setting a default for an inherited accessor
       ref $_[0]
@@ -133,10 +137,6 @@ for my $meth (keys %$storage_accessor_idx, qw(
         and
       ! $_[0]->{_in_determine_driver}
         and
-      # if this is a known *setter* - just set it, no need to connect
-      # and determine the driver
-      ( %1$s or @_ <= 1 )
-        and
       # Only try to determine stuff if we have *something* that either is or can
       # provide a DSN. Allows for bare $schema's generated with a plain ->connect()
       # to still be marginally useful
@@ -1110,10 +1110,16 @@ sub get_dbms_capability {
 sub _server_info {
   my $self = shift;
 
-  my $info;
-  unless ($info = $self->_dbh_details->{info}) {
+  # FIXME - ideally this needs to be an ||= assignment, and the final
+  # assignment at the end of this do{} should be gone entirely. However
+  # this confuses CXSA: https://rt.cpan.org/Ticket/Display.html?id=103296
+  $self->_dbh_details->{info} || do {
+
+    # this guarantees that problematic conninfo won't be hidden
+    # by the try{} below
+    $self->ensure_connected;
 
-    $info = {};
+    my $info = {};
 
     my $server_version = try {
       $self->_get_server_version
@@ -1150,9 +1156,7 @@ sub _server_info {
     }
 
     $self->_dbh_details->{info} = $info;
-  }
-
-  return $info;
+  };
 }
 
 sub _get_server_version {
@@ -1331,7 +1335,7 @@ sub _extract_driver_from_connect_info {
 sub _determine_connector_driver {
   my ($self, $conn) = @_;
 
-  my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME');
+  my $dbtype = $self->_get_rdbms_name;
 
   if (not $dbtype) {
     $self->_warn_undetermined_driver(
@@ -1358,6 +1362,8 @@ sub _determine_connector_driver {
   }
 }
 
+sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') }
+
 sub _warn_undetermined_driver {
   my ($self, $msg) = @_;
 
@@ -1371,24 +1377,40 @@ sub _warn_undetermined_driver {
 }
 
 sub _do_connection_actions {
-  my $self          = shift;
-  my $method_prefix = shift;
-  my $call          = shift;
-
-  if (not ref($call)) {
-    my $method = $method_prefix . $call;
-    $self->$method(@_);
-  } elsif (ref($call) eq 'CODE') {
-    $self->$call(@_);
-  } elsif (ref($call) eq 'ARRAY') {
-    if (ref($call->[0]) ne 'ARRAY') {
-      $self->_do_connection_actions($method_prefix, $_) for @$call;
-    } else {
-      $self->_do_connection_actions($method_prefix, @$_) for @$call;
+  my ($self, $method_prefix, $call, @args) = @_;
+
+  try {
+    if (not ref($call)) {
+      my $method = $method_prefix . $call;
+      $self->$method(@args);
+    }
+    elsif (ref($call) eq 'CODE') {
+      $self->$call(@args);
+    }
+    elsif (ref($call) eq 'ARRAY') {
+      if (ref($call->[0]) ne 'ARRAY') {
+        $self->_do_connection_actions($method_prefix, $_) for @$call;
+      }
+      else {
+        $self->_do_connection_actions($method_prefix, @$_) for @$call;
+      }
+    }
+    else {
+      $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) );
     }
-  } else {
-    $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) );
   }
+  catch {
+    if ( $method_prefix =~ /^connect/ ) {
+      # this is an on_connect cycle - we can't just throw while leaving
+      # a handle in an undefined state in our storage object
+      # kill it with fire and rethrow
+      $self->_dbh(undef);
+      $self->throw_exception( $_[0] );
+    }
+    else {
+      carp "Disconnect action failed: $_[0]";
+    }
+  };
 
   return $self;
 }
@@ -1669,8 +1691,8 @@ sub _gen_sql_bind {
   ) {
     carp_unique 'DateTime objects passed to search() are not supported '
       . 'properly (InflateColumn::DateTime formats and settings are not '
-      . 'respected.) See "Formatting DateTime objects in queries" in '
-      . 'DBIx::Class::Manual::Cookbook. To disable this warning for good '
+      . 'respected.) See ".. format a DateTime object for searching?" in '
+      . 'DBIx::Class::Manual::FAQ. To disable this warning for good '
       . 'set $ENV{DBIC_DT_SEARCH_OK} to true'
   }
 
@@ -1700,7 +1722,6 @@ sub _resolve_bindattrs {
   };
 
   return [ map {
-    my $resolved =
       ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ]
     : ( ! defined $_->[0] )             ? [ {}, $_->[1] ]
     : (ref $_->[0] eq 'HASH')           ? [(
@@ -1717,31 +1738,6 @@ sub _resolve_bindattrs {
     :                                     [ $resolve_bindinfo->(
                                               { dbic_colname => $_->[0] }
                                             ), $_->[1] ]
-    ;
-
-    if (
-      ! exists $resolved->[0]{dbd_attrs}
-        and
-      ! $resolved->[0]{sqlt_datatype}
-        and
-      length ref $resolved->[1]
-        and
-      ! is_plain_value $resolved->[1]
-    ) {
-      require Data::Dumper;
-      local $Data::Dumper::Maxdepth = 1;
-      local $Data::Dumper::Terse = 1;
-      local $Data::Dumper::Useqq = 1;
-      local $Data::Dumper::Indent = 0;
-      local $Data::Dumper::Pad = ' ';
-      $self->throw_exception(
-        'You must supply a datatype/bindtype (see DBIx::Class::ResultSet/DBIC BIND VALUES) '
-      . 'for non-scalar value '. Data::Dumper::Dumper ($resolved->[1])
-      );
-    }
-
-    $resolved;
-
   } @$bind ];
 }
 
@@ -2219,7 +2215,7 @@ sub _insert_bulk {
   # scope guard
   my $guard = $self->txn_scope_guard;
 
-  $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () );
+  $self->_query_start( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
   my $sth = $self->_prepare_sth($self->_dbh, $sql);
   my $rv = do {
     if (@$proto_bind) {
@@ -2233,7 +2229,7 @@ sub _insert_bulk {
     }
   };
 
-  $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () );
+  $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
 
   $guard->commit;
 
@@ -2290,10 +2286,12 @@ sub _dbh_execute_for_fetch {
 
       # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
       # For the time being forcibly stringify whatever is stringifiable
-      (length ref $v and is_plain_value $v)
-        ? "$v"
-        : $v
-      ;
+      my $vref;
+
+      ( !length ref $v or ! ($vref = is_plain_value $v) )   ? $v
+    : defined blessed( $$vref )                             ? "$$vref"
+                                                            : $$vref
+    ;
     } map { $_->[0] } @$proto_bind ];
   };