Fix oversight in 096ab902 breaking { -value => $array } insertion

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 25a4513..40ae3f9 100644 (file)
--- 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
@@ -1115,6 +1115,10 @@ sub _server_info {
   # 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;
+
     my $info = {};
 
     my $server_version = try {
@@ -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) = @_;
 
@@ -1373,6 +1379,7 @@ sub _warn_undetermined_driver {
 sub _do_connection_actions {
   my ($self, $method_prefix, $call, @args) = @_;
 
+  try {
     if (not ref($call)) {
       my $method = $method_prefix . $call;
       $self->$method(@args);
@@ -1391,6 +1398,19 @@ sub _do_connection_actions {
     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;
 }
@@ -1702,7 +1722,6 @@ sub _resolve_bindattrs {
   };
 
   return [ map {
-    my $resolved =
       ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ]
     : ( ! defined $_->[0] )             ? [ {}, $_->[1] ]
     : (ref $_->[0] eq 'HASH')           ? [(
@@ -1719,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 ];
 }
 
@@ -2292,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 ];
   };