X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=45afefcfd2e7158b64bf46eb70be92fc92ea74bb;hb=5efba7fcc89e113c60d78fa246a0217c405ea1fc;hp=d9fa57ac85201376663574f81e6df45770c5e237;hpb=fabbd5cca97aaef8e605a783c78abc1eaf9bdbae;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index d9fa57a..45afefc 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -12,9 +12,11 @@ use DBIx::Class::Exception;
 use Scalar::Util qw/refaddr weaken reftype blessed/;
 use List::Util qw/first/;
 use Sub::Name 'subname';
+use Context::Preserve 'preserve_context';
 use Try::Tiny;
 use overload ();
 use Data::Compare (); # no imports!!! guard against insane architecture
+use DBI::Const::GetInfoType (); # no import of retarded global hash
 use namespace::clean;
 
 # default cursor class, overridable in connect_info attributes
@@ -1105,12 +1107,18 @@ sub _server_info {
 }
 
 sub _get_server_version {
-  shift->_dbh_get_info(18);
+  shift->_dbh_get_info('SQL_DBMS_VER');
 }
 
 sub _dbh_get_info {
   my ($self, $info) = @_;
 
+  if ($info =~ /[^0-9]/) {
+    $info = $DBI::Const::GetInfoType::GetInfoType{$info};
+    $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType")
+      unless defined $info;
+  }
+
   return try { $self->_get_dbh->get_info($info) } || undef;
 }
 
@@ -1235,10 +1243,7 @@ sub _connect {
 
   my ($old_connect_via, $dbh);
 
-  if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
-    $old_connect_via = $DBI::connect_via;
-    $DBI::connect_via = 'connect';
-  }
+  local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
 
   try {
     if(ref $info[0] eq 'CODE') {
@@ -1300,9 +1305,6 @@ sub _connect {
   }
   catch {
     $self->throw_exception("DBI Connection failed: $_")
-  }
-  finally {
-    $DBI::connect_via = $old_connect_via if $old_connect_via;
   };
 
   $self->_dbh_autocommit($dbh->{AutoCommit});
@@ -2116,6 +2118,10 @@ sub _select {
 sub _select_args_to_query {
   my $self = shift;
 
+  $self->throw_exception(
+    "Unable to generate limited query representation with 'software_limit' enabled"
+  ) if ($_[3]->{software_limit} and ($_[3]->{offset} or $_[3]->{rows}) );
+
   # my ($op, $ident, $select, $cond, $rs_attrs, $rows, $offset)
   #  = $self->_select_args($ident, $select, $cond, $attrs);
   my ($op, $ident, @args) =
@@ -2169,8 +2175,8 @@ sub _select_args {
   # see if we need to tear the prefetch apart otherwise delegate the limiting to the
   # storage, unless software limit was requested
   if (
-    #limited has_many
-    ( $attrs->{rows} && keys %{$attrs->{collapse}} )
+    # limited collapsing has_many
+    ( $attrs->{rows} && $attrs->{collapse} )
        ||
     # grouped prefetch (to satisfy group_by == select)
     ( $attrs->{group_by}
@@ -2191,7 +2197,15 @@ sub _select_args {
   }
 
   # try to simplify the joinmap further (prune unreferenced type-single joins)
-  $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs);
+  if (
+    ref $ident
+      and
+    reftype $ident eq 'ARRAY'
+      and
+    @$ident != 1
+  ) {
+    $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs);
+  }
 
 ###
   # This would be the point to deflate anything found in $where
@@ -2748,18 +2762,12 @@ sub deployment_statements {
     data => $schema,
   );
 
-  my @ret;
-  if (wantarray) {
-    @ret = $tr->translate;
-  }
-  else {
-    $ret[0] = $tr->translate;
-  }
-
-  $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
-    unless (@ret && defined $ret[0]);
-
-  return wantarray ? @ret : $ret[0];
+  return preserve_context {
+    $tr->translate
+  } after => sub {
+    $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
+      unless defined $_[0];
+  };
 }
 
 # FIXME deploy() currently does not accurately report sql errors
@@ -2950,6 +2958,13 @@ sub _is_text_lob_type {
                         |national\s*character\s*varying))\z/xi);
 }
 
+# Determine if a data_type is some type of a binary type
+sub _is_binary_type {
+  my ($self, $data_type) = @_;
+  $data_type && ($self->_is_binary_lob_type($data_type)
+    || $data_type =~ /(?:var)?(?:binary|bit|graphic)(?:\s*varying)?/i);
+}
+
 1;
 
 =head1 USAGE NOTES