From: Peter Rabbitson <ribasushi@cpan.org>
Date: Fri, 3 Jul 2009 10:06:57 +0000 (+0000)
Subject: Fix some mssql shortcommings when confronted with the new subequeried prefetch sql
X-Git-Tag: v0.08108~12^2~6
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ac93965c38f39697a3f568f4616f5e20237536ea;p=dbsrgits%2FDBIx-Class.git

Fix some mssql shortcommings when confronted with the new subequeried prefetch sql
---

diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm
index e6ae5b5..8399cf0 100644
--- a/lib/DBIx/Class/SQLAHacks.pm
+++ b/lib/DBIx/Class/SQLAHacks.pm
@@ -135,8 +135,11 @@ sub _Top {
   }
 
   my $name_sep = $self->name_sep || '.';
-  $name_sep = "\Q$name_sep\E";
-  my $col_re = qr/ ^ (?: (.+) $name_sep )? ([^$name_sep]+) $ /x;
+  my $esc_name_sep = "\Q$name_sep\E";
+  my $col_re = qr/ ^ (?: (.+) $esc_name_sep )? ([^$esc_name_sep]+) $ /x;
+
+  my $rs_alias = $self->{_dbic_rs_attrs}{alias};
+  my $quoted_rs_alias = $self->_quote ($rs_alias);
 
   # construct the new select lists, rename(alias) some columns if necessary
   my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases);
@@ -219,7 +222,6 @@ sub _Top {
     $limit_order = $req_order;
   }
   else {
-    my $rs_alias = $self->{_dbic_rs_attrs}{alias};
     $limit_order = [ map
       { join ('', $rs_alias, $name_sep, $_ ) }
       ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns )
@@ -260,7 +262,7 @@ sub _Top {
     SELECT TOP $rows $outer_select FROM
     (
       $sql
-    ) AS me
+    ) $quoted_rs_alias
     $order_by_outer
 SQL
 
@@ -270,12 +272,13 @@ SQL
     $sql = <<"SQL";
 
     SELECT $outer_select FROM
-      ( $sql ) AS me
-    $order_by_requested;
+      ( $sql ) $quoted_rs_alias
+    $order_by_requested
 SQL
 
   }
 
+  $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line
   return $sql;
 }
 
diff --git a/lib/DBIx/Class/SQLAHacks/MSSQL.pm b/lib/DBIx/Class/SQLAHacks/MSSQL.pm
new file mode 100644
index 0000000..1b18b1e
--- /dev/null
+++ b/lib/DBIx/Class/SQLAHacks/MSSQL.pm
@@ -0,0 +1,33 @@
+package # Hide from PAUSE
+  DBIx::Class::SQLAHacks::MSSQL;
+
+use base qw( DBIx::Class::SQLAHacks );
+use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
+
+#
+# MSSQL is retarded wrt TOP (crappy limit) and ordering.
+# One needs to add a TOP to *all* ordered subqueries, if
+# TOP has been used in the statement at least once.
+# Do it here.
+#
+sub select {
+  my $self = shift;
+
+  my ($sql, @bind) = $self->SUPER::select (@_);
+
+  # ordering was requested and there are at least 2 SELECT/FROM pairs
+  # (thus subquery), and there is no TOP specified
+  if (
+    $sql =~ /\bSELECT\b .+? \bFROM\b .+? \bSELECT\b .+? \bFROM\b/isx
+      &&
+    $sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ /xi
+      &&
+    scalar $self->_order_by_chunks ($_[3]->{order_by})
+  ) {
+    $sql =~ s/^ \s* SELECT \s/SELECT TOP 100 PERCENT /xi;
+  }
+
+  return wantarray ? ($sql, @bind) : $sql;
+}
+
+1;
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index ba36ad6..fdecba5 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -1376,7 +1376,7 @@ sub _select_args_to_query {
 sub _select_args {
   my ($self, $ident, $select, $where, $attrs) = @_;
 
-  my ($alias2source, $root_alias) = $self->_resolve_ident_sources ($ident);
+  my ($alias2source, $rs_alias) = $self->_resolve_ident_sources ($ident);
 
   my $sql_maker = $self->sql_maker;
   $sql_maker->{_dbic_rs_attrs} = {
@@ -1384,7 +1384,10 @@ sub _select_args {
     select => $select,
     from => $ident,
     where => $where,
-    _source_handle => $alias2source->{$root_alias}->handle,
+    $rs_alias
+      ? ( _source_handle => $alias2source->{$rs_alias}->handle )
+      : ()
+    ,
   };
 
   # calculate bind_attrs before possible $ident mangling
@@ -1397,7 +1400,7 @@ sub _select_args {
       $bind_attrs->{$fqcn} = $bindtypes->{$col} if $bindtypes->{$col};
 
       # so that unqualified searches can be bound too
-      $bind_attrs->{$col} = $bind_attrs->{$fqcn} if $alias eq $root_alias;
+      $bind_attrs->{$col} = $bind_attrs->{$fqcn} if $alias eq $rs_alias;
     }
   }
 
@@ -1452,23 +1455,28 @@ sub _select_args {
   return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit);
 }
 
+#
+# This is the code producing joined subqueries like:
+# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ... 
+#
 sub _adjust_select_args_for_complex_prefetch {
   my ($self, $from, $select, $where, $attrs) = @_;
 
+  $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
+    if (ref $from ne 'ARRAY');
+
   # copies for mangling
   $from = [ @$from ];
   $select = [ @$select ];
   $attrs = { %$attrs };
 
-  $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
-    if (ref $from ne 'ARRAY');
-
   # separate attributes
   my $sub_attrs = { %$attrs };
   delete $attrs->{$_} for qw/where bind rows offset group_by having/;
   delete $sub_attrs->{$_} for qw/for collapse prefetch_select _collapse_order_by select as/;
 
   my $alias = $attrs->{alias};
+  my $sql_maker = $self->sql_maker;
 
   # create subquery select list - loop only over primary columns
   my $sub_select = [];
@@ -1495,7 +1503,7 @@ sub _adjust_select_args_for_complex_prefetch {
   }
 
   # mangle {from}
-  my $select_root = shift @$from;
+  my $join_root = shift @$from;
   my @outer_from = @$from;
 
   my %inner_joins;
@@ -1505,7 +1513,7 @@ sub _adjust_select_args_for_complex_prefetch {
   # so always include it in the inner join, and also shift away
   # from the outer stack, so that the two datasets actually do
   # meet
-  if ($select_root->{-alias} ne $alias) {
+  if ($join_root->{-alias} ne $alias) {
     $inner_joins{$alias} = 1;
 
     while (@outer_from && $outer_from[0][0]{-alias} ne $alias) {
@@ -1536,7 +1544,6 @@ sub _adjust_select_args_for_complex_prefetch {
   # It may not be very efficient, but it's a reasonable stop-gap
   {
     # produce stuff unquoted, so it can be scanned
-    my $sql_maker = $self->sql_maker;
     local $sql_maker->{quote_char};
 
     my @order_by = (map
@@ -1576,14 +1583,13 @@ sub _adjust_select_args_for_complex_prefetch {
   }
 
   # construct the inner $from for the subquery
-  my $inner_from = [ $select_root ];
+  my $inner_from = [ $join_root ];
   for my $j (@$from) {
     push @$inner_from, $j if $inner_joins{$j->[0]{-alias}};
   }
 
   # if a multi-type join was needed in the subquery ("multi" is indicated by
   # presence in {collapse}) - add a group_by to simulate the collapse in the subq
-
   for my $alias (keys %inner_joins) {
 
     # the dot comes from some weirdness in collapse
@@ -1605,7 +1611,7 @@ sub _adjust_select_args_for_complex_prefetch {
   # put it in the new {from}
   unshift @outer_from, {
     -alias => $alias,
-    -source_handle => $select_root->{-source_handle},
+    -source_handle => $join_root->{-source_handle},
     $alias => $subq,
   };
 
@@ -1623,14 +1629,14 @@ sub _resolve_ident_sources {
   my ($self, $ident) = @_;
 
   my $alias2source = {};
-  my $root_alias;
+  my $rs_alias;
 
   # the reason this is so contrived is that $ident may be a {from}
   # structure, specifying multiple tables to join
   if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
     # this is compat mode for insert/update/delete which do not deal with aliases
     $alias2source->{me} = $ident;
-    $root_alias = 'me';
+    $rs_alias = 'me';
   }
   elsif (ref $ident eq 'ARRAY') {
 
@@ -1638,7 +1644,7 @@ sub _resolve_ident_sources {
       my $tabinfo;
       if (ref $_ eq 'HASH') {
         $tabinfo = $_;
-        $root_alias = $tabinfo->{-alias};
+        $rs_alias = $tabinfo->{-alias};
       }
       if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') {
         $tabinfo = $_->[0];
@@ -1649,7 +1655,7 @@ sub _resolve_ident_sources {
     }
   }
 
-  return ($alias2source, $root_alias);
+  return ($alias2source, $rs_alias);
 }
 
 # Takes $ident, \@column_names
diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm
index c6b9360..3a7ac84 100644
--- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm
+++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm
@@ -5,6 +5,8 @@ use warnings;
 
 use base qw/DBIx::Class::Storage::DBI::AmbiguousGlob DBIx::Class::Storage::DBI/;
 
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MSSQL');
+
 sub _dbh_last_insert_id {
   my ($self, $dbh, $source, $col) = @_;
   my ($id) = $dbh->selectrow_array('SELECT SCOPE_IDENTITY()');
diff --git a/t/03podcoverage.t b/t/03podcoverage.t
index fe8516b..5173028 100644
--- a/t/03podcoverage.t
+++ b/t/03podcoverage.t
@@ -117,6 +117,7 @@ my $exceptions = {
     'DBIx::Class::Storage::DBI::SQLite'                 => { skip => 1 },
     'DBIx::Class::Storage::DBI::mysql'                  => { skip => 1 },
     'DBIx::Class::SQLAHacks::MySQL'                     => { skip => 1 },
+    'DBIx::Class::SQLAHacks::MSSQL'                     => { skip => 1 },
     'SQL::Translator::Parser::DBIx::Class'              => { skip => 1 },
     'SQL::Translator::Producer::DBIx::Class::File'      => { skip => 1 },
 
diff --git a/t/746mssql.t b/t/746mssql.t
index a7edb6f..f5c0071 100644
--- a/t/746mssql.t
+++ b/t/746mssql.t
@@ -190,8 +190,10 @@ $schema->storage->_sql_maker->{name_sep} = '.';
     }, {
       distinct => 1,
       prefetch => 'owner',
-      order_by => 'name',
       rows     => 2,  # 3 results total
+      order_by => { -desc => 'owner' },
+      # there is no sane way to order by the right side of a grouped prefetch currently :(
+      #order_by => { -desc => 'owner.name' },
     });