Stop requiring explicit bindtype specification for non-scalar references
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm
index 483a6d0..3e746ad 100644 (file)
@@ -12,9 +12,8 @@ use Scalar::Util qw/refaddr weaken reftype blessed/;
 use List::Util qw/first/;
 use Context::Preserve 'preserve_context';
 use Try::Tiny;
-use Data::Compare (); # no imports!!! guard against insane architecture
 use SQL::Abstract qw(is_plain_value is_literal_value);
-use DBIx::Class::_Util qw(quote_sub perlstring);
+use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor);
 use namespace::clean;
 
 # default cursor class, overridable in connect_info attributes
@@ -120,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]
@@ -134,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
@@ -254,12 +253,12 @@ sub new {
 }
 
 sub DESTROY {
-  my $self = shift;
+  return if &detected_reinvoked_destructor;
 
+  $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   # some databases spew warnings on implicit disconnect
-  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   local $SIG{__WARN__} = sub {};
-  $self->_dbh(undef);
+  $_[0]->_dbh(undef);
 
   # this op is necessary, since the very last perl runtime statement
   # triggers a global destruction shootout, and the $SIG localization
@@ -270,14 +269,14 @@ sub DESTROY {
 
 # handle pid changes correctly - do not destroy parent's connection
 sub _verify_pid {
-  my $self = shift;
 
-  my $pid = $self->_conn_pid;
-  if( defined $pid and $pid != $$ and my $dbh = $self->_dbh ) {
+  my $pid = $_[0]->_conn_pid;
+
+  if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) {
     $dbh->{InactiveDestroy} = 1;
-    $self->_dbh(undef);
-    $self->transaction_depth(0);
-    $self->savepoints([]);
+    $_[0]->_dbh(undef);
+    $_[0]->transaction_depth(0);
+    $_[0]->savepoints([]);
   }
 
   return;
@@ -871,22 +870,20 @@ database is not in C<AutoCommit> mode.
 =cut
 
 sub disconnect {
-  my ($self) = @_;
-
-  if( $self->_dbh ) {
-    my @actions;
 
-    push @actions, ( $self->on_disconnect_call || () );
-    push @actions, $self->_parse_connect_do ('on_disconnect_do');
+  if( my $dbh = $_[0]->_dbh ) {
 
-    $self->_do_connection_actions(disconnect_call_ => $_) for @actions;
+    $_[0]->_do_connection_actions(disconnect_call_ => $_) for (
+      ( $_[0]->on_disconnect_call || () ),
+      $_[0]->_parse_connect_do ('on_disconnect_do')
+    );
 
     # stops the "implicit rollback on disconnect" warning
-    $self->_exec_txn_rollback unless $self->_dbh_autocommit;
+    $_[0]->_exec_txn_rollback unless $_[0]->_dbh_autocommit;
 
-    %{ $self->_dbh->{CachedKids} } = ();
-    $self->_dbh->disconnect;
-    $self->_dbh(undef);
+    %{ $dbh->{CachedKids} } = ();
+    $dbh->disconnect;
+    $_[0]->_dbh(undef);
   }
 }
 
@@ -907,8 +904,8 @@ in MySQL's case disabled entirely.
 
 # Storage subclasses should override this
 sub with_deferred_fk_checks {
-  my ($self, $sub) = @_;
-  $sub->();
+  #my ($self, $sub) = @_;
+  $_[1]->();
 }
 
 =head2 connected
@@ -928,40 +925,26 @@ answering, etc.) This method is used internally by L</dbh>.
 =cut
 
 sub connected {
-  my $self = shift;
-  return 0 unless $self->_seems_connected;
+  return 0 unless $_[0]->_seems_connected;
 
   #be on the safe side
-  local $self->_dbh->{RaiseError} = 1;
+  local $_[0]->_dbh->{RaiseError} = 1;
 
-  return $self->_ping;
+  return $_[0]->_ping;
 }
 
 sub _seems_connected {
-  my $self = shift;
-
-  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
-
-  my $dbh = $self->_dbh
-    or return 0;
+  $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
 
-  return $dbh->FETCH('Active');
+  ($_[0]->_dbh || return 0)->FETCH('Active');
 }
 
 sub _ping {
-  my $self = shift;
-
-  my $dbh = $self->_dbh or return 0;
-
-  return $dbh->ping;
+  ($_[0]->_dbh || return 0)->ping;
 }
 
 sub ensure_connected {
-  my ($self) = @_;
-
-  unless ($self->connected) {
-    $self->_populate_dbh;
-  }
+  $_[0]->connected || ( $_[0]->_populate_dbh && 1 );
 }
 
 =head2 dbh
@@ -975,22 +958,17 @@ instead.
 =cut
 
 sub dbh {
-  my ($self) = @_;
-
-  if (not $self->_dbh) {
-    $self->_populate_dbh;
-  } else {
-    $self->ensure_connected;
-  }
-  return $self->_dbh;
+  # maybe save a ping call
+  $_[0]->_dbh
+    ? ( $_[0]->ensure_connected and $_[0]->_dbh )
+    : $_[0]->_populate_dbh
+  ;
 }
 
 # this is the internal "get dbh or connect (don't check)" method
 sub _get_dbh {
-  my $self = shift;
-  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
-  $self->_populate_dbh unless $self->_dbh;
-  return $self->_dbh;
+  $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
+  $_[0]->_dbh || $_[0]->_populate_dbh;
 }
 
 # *DELIBERATELY* not a setter (for the time being)
@@ -1059,33 +1037,35 @@ sub _rebless {}
 sub _init {}
 
 sub _populate_dbh {
-  my ($self) = @_;
 
-  $self->_dbh(undef); # in case ->connected failed we might get sent here
-  $self->_dbh_details({}); # reset everything we know
-  $self->_sql_maker(undef); # this may also end up being different
+  $_[0]->_dbh(undef); # in case ->connected failed we might get sent here
 
-  $self->_dbh($self->_connect);
+  $_[0]->_dbh_details({}); # reset everything we know
 
-  $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
+  # FIXME - this needs reenabling with the proper "no reset on same DSN" check
+  #$_[0]->_sql_maker(undef); # this may also end up being different
 
-  $self->_determine_driver;
+  $_[0]->_dbh($_[0]->_connect);
+
+  $_[0]->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
+
+  $_[0]->_determine_driver;
 
   # Always set the transaction depth on connect, since
   #  there is no transaction in progress by definition
-  $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
+  $_[0]->{transaction_depth} = $_[0]->_dbh_autocommit ? 0 : 1;
 
-  $self->_run_connection_actions unless $self->{_in_determine_driver};
+  $_[0]->_run_connection_actions unless $_[0]->{_in_determine_driver};
+
+  $_[0]->_dbh;
 }
 
 sub _run_connection_actions {
-  my $self = shift;
-  my @actions;
 
-  push @actions, ( $self->on_connect_call || () );
-  push @actions, $self->_parse_connect_do ('on_connect_do');
-
-  $self->_do_connection_actions(connect_call_ => $_) for @actions;
+  $_[0]->_do_connection_actions(connect_call_ => $_) for (
+    ( $_[0]->on_connect_call || () ),
+    $_[0]->_parse_connect_do ('on_connect_do'),
+  );
 }
 
 
@@ -1130,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
@@ -1170,9 +1156,7 @@ sub _server_info {
     }
 
     $self->_dbh_details->{info} = $info;
-  }
-
-  return $info;
+  };
 }
 
 sub _get_server_version {
@@ -1351,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(
@@ -1378,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) = @_;
 
@@ -1391,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;
 }
@@ -1423,7 +1425,19 @@ sub disconnect_call_do_sql {
   $self->_do_query(@_);
 }
 
-# override in db-specific backend when necessary
+=head2 connect_call_datetime_setup
+
+A no-op stub method, provided so that one can always safely supply the
+L<connection option|/DBIx::Class specific connection attributes>
+
+ on_connect_call => 'datetime_setup'
+
+This way one does not need to know in advance whether the underlying
+storage requires any sort of hand-holding when dealing with calendar
+data.
+
+=cut
+
 sub connect_call_datetime_setup { 1 }
 
 sub _do_query {
@@ -1543,19 +1557,17 @@ sub _connect {
 }
 
 sub txn_begin {
-  my $self = shift;
-
   # this means we have not yet connected and do not know the AC status
   # (e.g. coderef $dbh), need a full-fledged connection check
-  if (! defined $self->_dbh_autocommit) {
-    $self->ensure_connected;
+  if (! defined $_[0]->_dbh_autocommit) {
+    $_[0]->ensure_connected;
   }
   # Otherwise simply connect or re-connect on pid changes
   else {
-    $self->_get_dbh;
+    $_[0]->_get_dbh;
   }
 
-  $self->next::method(@_);
+  shift->next::method(@_);
 }
 
 sub _exec_txn_begin {
@@ -1576,9 +1588,8 @@ sub _exec_txn_begin {
 sub txn_commit {
   my $self = shift;
 
-  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   $self->throw_exception("Unable to txn_commit() on a disconnected storage")
-    unless $self->_dbh;
+    unless $self->_seems_connected;
 
   # esoteric case for folks using external $dbh handles
   if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
@@ -1607,9 +1618,8 @@ sub _exec_txn_commit {
 sub txn_rollback {
   my $self = shift;
 
-  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   $self->throw_exception("Unable to txn_rollback() on a disconnected storage")
-    unless $self->_dbh;
+    unless $self->_seems_connected;
 
   # esoteric case for folks using external $dbh handles
   if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
@@ -1637,9 +1647,8 @@ sub _exec_txn_rollback {
 
 # generate the DBI-specific stubs, which then fallback to ::Storage proper
 quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback);
-  $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   $_[0]->throw_exception('Unable to %s() on a disconnected storage')
-    unless $_[0]->_dbh;
+    unless $_[0]->_seems_connected;
   shift->next::method(@_);
 EOS
 
@@ -1682,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'
   }
 
@@ -1713,7 +1722,6 @@ sub _resolve_bindattrs {
   };
 
   return [ map {
-    my $resolved =
       ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ]
     : ( ! defined $_->[0] )             ? [ {}, $_->[1] ]
     : (ref $_->[0] eq 'HASH')           ? [(
@@ -1730,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 ];
 }
 
@@ -1788,31 +1771,28 @@ sub _query_end {
 }
 
 sub _dbi_attrs_for_bind {
-  my ($self, $ident, $bind) = @_;
+  #my ($self, $ident, $bind) = @_;
 
-  my @attrs;
+  return [ map {
 
-  for (map { $_->[0] } @$bind) {
-    push @attrs, do {
-      if (exists $_->{dbd_attrs}) {
-        $_->{dbd_attrs}
-      }
-      elsif($_->{sqlt_datatype}) {
-        # cache the result in the dbh_details hash, as it can not change unless
-        # we connect to something else
-        my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {};
-        if (not exists $cache->{$_->{sqlt_datatype}}) {
-          $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
-        }
-        $cache->{$_->{sqlt_datatype}};
-      }
-      else {
-        undef;  # always push something at this position
-      }
-    }
-  }
+    exists $_->{dbd_attrs}  ?  $_->{dbd_attrs}
+
+  : ! $_->{sqlt_datatype}   ? undef
+
+  :                           do {
+
+    # cache the result in the dbh_details hash, as it (usually) can not change
+    # unless we connect to something else
+    # FIXME: for the time being Oracle is an exception, pending a rewrite of
+    # the LOB storage
+    my $cache = $_[0]->_dbh_details->{_datatype_map_cache} ||= {};
 
-  return \@attrs;
+    $cache->{$_->{sqlt_datatype}} = $_[0]->bind_attribute_by_data_type($_->{sqlt_datatype})
+      if ! exists $cache->{$_->{sqlt_datatype}};
+
+    $cache->{$_->{sqlt_datatype}};
+
+  } } map { $_->[0] } @{$_[2]} ];
 }
 
 sub _execute {
@@ -2084,7 +2064,7 @@ sub _insert_bulk {
   # can't just hand SQLA a set of some known "values" (e.g. hashrefs that
   # can be later matched up by address), because we want to supply a real
   # value on which perhaps e.g. datatype checks will be performed
-  my ($proto_data, $value_type_by_col_idx);
+  my ($proto_data, $serialized_bind_type_by_col_idx);
   for my $col_idx (0..$#$cols) {
     my $colname = $cols->[$col_idx];
     if (ref $data->[0][$col_idx] eq 'SCALAR') {
@@ -2103,7 +2083,7 @@ sub _insert_bulk {
 
       # store value-less (attrs only) bind info - we will be comparing all
       # supplied binds against this for sanity
-      $value_type_by_col_idx->{$col_idx} = [ map { $_->[0] } @$resolved_bind ];
+      $serialized_bind_type_by_col_idx->{$col_idx} = serialize [ map { $_->[0] } @$resolved_bind ];
 
       $proto_data->{$colname} = \[ $sql, map { [
         # inject slice order to use for $proto_bind construction
@@ -2114,7 +2094,7 @@ sub _insert_bulk {
       ];
     }
     else {
-      $value_type_by_col_idx->{$col_idx} = undef;
+      $serialized_bind_type_by_col_idx->{$col_idx} = undef;
 
       $proto_data->{$colname} = \[ '?', [
         { dbic_colname => $colname, _bind_data_slice_idx => $col_idx }
@@ -2130,7 +2110,7 @@ sub _insert_bulk {
     [ $proto_data ],
   );
 
-  if (! @$proto_bind and keys %$value_type_by_col_idx) {
+  if (! @$proto_bind and keys %$serialized_bind_type_by_col_idx) {
     # if the bindlist is empty and we had some dynamic binds, this means the
     # storage ate them away (e.g. the NoBindVars component) and interpolated
     # them directly into the SQL. This obviously can't be good for multi-inserts
@@ -2164,7 +2144,7 @@ sub _insert_bulk {
     for my $row_idx (1..$#$data) {  # we are comparing against what we got from [0] above, hence start from 1
       my $val = $data->[$row_idx][$col_idx];
 
-      if (! exists $value_type_by_col_idx->{$col_idx}) { # literal no binds
+      if (! exists $serialized_bind_type_by_col_idx->{$col_idx}) { # literal no binds
         if (ref $val ne 'SCALAR') {
           $bad_slice_report_cref->(
             "Incorrect value (expecting SCALAR-ref \\'$$reference_val')",
@@ -2180,7 +2160,7 @@ sub _insert_bulk {
           );
         }
       }
-      elsif (! defined $value_type_by_col_idx->{$col_idx} ) {  # regular non-literal value
+      elsif (! defined $serialized_bind_type_by_col_idx->{$col_idx} ) {  # regular non-literal value
         if (is_literal_value($val)) {
           $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx);
         }
@@ -2208,16 +2188,17 @@ sub _insert_bulk {
           }
           # need to check the bind attrs - a bind will happen only once for
           # the entire dataset, so any changes further down will be ignored.
-          elsif (! Data::Compare::Compare(
-            $value_type_by_col_idx->{$col_idx},
-            [
+          elsif (
+            $serialized_bind_type_by_col_idx->{$col_idx}
+              ne
+            serialize [
               map
               { $_->[0] }
               @{$self->_resolve_bindattrs(
                 $source, [ @{$$val}[1 .. $#$$val] ], $colinfos,
               )}
-            ],
-          )) {
+            ]
+          ) {
             $bad_slice_report_cref->(
               'Differing bind attributes on literal/bind values not supported',
               $row_idx,
@@ -2234,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) {
@@ -2248,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;
 
@@ -2598,9 +2579,9 @@ see L<DBIx::Class::SQLMaker::LimitDialects>.
 sub _dbh_columns_info_for {
   my ($self, $dbh, $table) = @_;
 
-  if ($dbh->can('column_info')) {
-    my %result;
-    my $caught;
+  my %result;
+
+  if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) {
     try {
       my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
       my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
@@ -2617,39 +2598,75 @@ sub _dbh_columns_info_for {
         $result{$col_name} = \%column_info;
       }
     } catch {
-      $caught = 1;
+      %result = ();
     };
-    return \%result if !$caught && scalar keys %result;
+
+    return \%result if keys %result;
   }
 
-  my %result;
   my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
   $sth->execute;
-  my @columns = @{$sth->{NAME_lc}};
-  for my $i ( 0 .. $#columns ){
-    my %column_info;
-    $column_info{data_type} = $sth->{TYPE}->[$i];
-    $column_info{size} = $sth->{PRECISION}->[$i];
-    $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
-
-    if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
-      $column_info{data_type} = $1;
-      $column_info{size}    = $2;
+
+### The acrobatics with lc names is necessary to support both the legacy
+### API that used NAME_lc exclusively, *AND* at the same time work properly
+### with column names differing in cas eonly (thanks pg!)
+
+  my ($columns, $seen_lcs);
+
+  ++$seen_lcs->{lc($_)} and $columns->{$_} = {
+    idx => scalar keys %$columns,
+    name => $_,
+    lc_name => lc($_),
+  } for @{$sth->{NAME}};
+
+  $seen_lcs->{$_->{lc_name}} == 1
+    and
+  $_->{name} = $_->{lc_name}
+    for values %$columns;
+
+  for ( values %$columns ) {
+    my $inf = {
+      data_type => $sth->{TYPE}->[$_->{idx}],
+      size => $sth->{PRECISION}->[$_->{idx}],
+      is_nullable => $sth->{NULLABLE}->[$_->{idx}] ? 1 : 0,
+    };
+
+    if ($inf->{data_type} =~ m/^(.*?)\((.*?)\)$/) {
+      @{$inf}{qw( data_type  size)} = ($1, $2);
     }
 
-    $result{$columns[$i]} = \%column_info;
+    $result{$_->{name}} = $inf;
   }
+
   $sth->finish;
 
-  foreach my $col (keys %result) {
-    my $colinfo = $result{$col};
-    my $type_num = $colinfo->{data_type};
-    my $type_name;
-    if(defined $type_num && $dbh->can('type_info')) {
-      my $type_info = $dbh->type_info($type_num);
-      $type_name = $type_info->{TYPE_NAME} if $type_info;
-      $colinfo->{data_type} = $type_name if $type_name;
+  if ($dbh->can('type_info')) {
+    for my $inf (values %result) {
+      next if ! defined $inf->{data_type};
+
+      $inf->{data_type} = (
+        (
+          (
+            $dbh->type_info( $inf->{data_type} )
+              ||
+            next
+          )
+            ||
+          next
+        )->{TYPE_NAME}
+          ||
+        next
+      );
+
+      # FIXME - this may be an artifact of the DBD::Pg implmentation alone
+      # needs more testing in the future...
+      $inf->{size} -= 4 if (
+        ( $inf->{size}||0 > 4 )
+          and
+        $inf->{data_type} =~ qr/^text$/i
+      );
     }
+
   }
 
   return \%result;
@@ -2885,8 +2902,8 @@ sub create_ddl_dir {
     %{$sqltargs || {}}
   };
 
-  unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) {
-    $self->throw_exception("Can't create a ddl file without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+  if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) {
+    $self->throw_exception("Can't create a ddl file without $missing");
   }
 
   my $sqlt = SQL::Translator->new( $sqltargs );
@@ -3008,7 +3025,8 @@ sub create_ddl_dir {
 
 =back
 
-Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
+Returns the statements used by L<DBIx::Class::Storage/deploy>
+and L<DBIx::Class::Schema/deploy>.
 
 The L<SQL::Translator> (not L<DBI>) database driver name can be explicitly
 provided in C<$type>, otherwise the result of L</sqlt_type> is used as default.
@@ -3041,8 +3059,8 @@ sub deployment_statements {
       return join('', @rows);
   }
 
-  unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) {
-    $self->throw_exception("Can't deploy without a ddl_dir or " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+  if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ) {
+    $self->throw_exception("Can't deploy without a pregenerated 'ddl_dir' directory or $missing");
   }
 
   # sources needs to be a parser arg, but for simplicity allow at top level
@@ -3285,13 +3303,13 @@ transactions.  You're on your own for handling all sorts of exceptional
 cases if you choose the C<< AutoCommit => 0 >> path, just as you would
 be with raw DBI.
 
+=head1 FURTHER QUESTIONS?
 
-=head1 AUTHOR AND CONTRIBUTORS
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 COPYRIGHT AND LICENSE
 
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.