[Bast-commits] r6734 - in DBIx-Class/0.08/branches/mssql_top_fixes: lib/DBIx/Class lib/DBIx/Class/Storage t

ribasushi at dev.catalyst.perl.org ribasushi at dev.catalyst.perl.org
Sat Jun 20 08:34:44 GMT 2009


Author: ribasushi
Date: 2009-06-20 08:34:42 +0000 (Sat, 20 Jun 2009)
New Revision: 6734

Modified:
   DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/SQLAHacks.pm
   DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/Storage/DBI.pm
   DBIx-Class/0.08/branches/mssql_top_fixes/t/746mssql.t
Log:
Maybe I've nailed it

Modified: DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/SQLAHacks.pm
===================================================================
--- DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/SQLAHacks.pm	2009-06-20 08:16:02 UTC (rev 6733)
+++ DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/SQLAHacks.pm	2009-06-20 08:34:42 UTC (rev 6734)
@@ -119,44 +119,90 @@
   # mangle the input sql so it can be properly aliased in the outer queries
   $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix
     or croak "Unrecognizable SELECT: $sql";
-  my $select = $1;
+  my $sql_select = $1;
+  my @sql_select = split (/\s*,\s*/, $sql_select);
 
-  my (@outer_select, %col_index);
-  for my $selected_col (@{$self->{_dbic_rs_attrs}{select}}) {
+  # we can't support subqueries (in fact MSSQL can't) - croak
+  if (@sql_select != @{$self->{_dbic_rs_attrs}{select}}) {
+    croak (sprintf (
+      'SQL SELECT did not parse cleanly - retrieved %d comma separated elements, while '
+    . 'the resultset select attribure contains %d elements: %s',
+      scalar @sql_select,
+      scalar @{$self->{_dbic_rs_attrs}{select}},
+      $sql_select,
+    ));
+  }
 
-    my $new_colname;
+  my $name_sep = $self->name_sep || '.';
+  $name_sep = "\Q$name_sep\E";
+  my $col_re = qr/ ^ (?: (.+) $name_sep )? ([^$name_sep]+) $ /x;
 
-    if (ref $selected_col) {
-      $new_colname = $self->_quote ('column_' . (@outer_select + 1) );
+  # construct the new select lists, rename(alias) some columns if necessary
+  my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases);
+
+  for (@{$self->{_dbic_rs_attrs}{select}}) {
+    next if ref $_;
+    my ($table, $orig_colname) = ( $_ =~ $col_re );
+    next unless $table;
+    $seen_names{$orig_colname}++;
+  }
+
+  for my $i (0 .. $#sql_select) {
+
+    my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i];
+    my $colsel_sql = $sql_select[$i];
+
+    # this may or may not work (in case of a scalarref or something)
+    my ($table, $orig_colname) = ( $colsel_arg =~ $col_re );
+
+    my $quoted_alias;
+    # do not attempt to understand non-scalar selects - alias numerically
+    if (ref $colsel_arg) {
+      $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) );
     }
-    else {
-      my $quoted_col = $self->_quote ($selected_col);
+    # column name seen more than once - alias it
+    elsif ($orig_colname && ($seen_names{$orig_colname} > 1) ) {
+      $quoted_alias = $self->_quote ("${table}__${orig_colname}");
+    }
 
-      my $name_sep = $self->name_sep || '.';
-      $name_sep = "\Q$name_sep\E";
+    # we did rename - make a record and adjust
+    if ($quoted_alias) {
+      # alias inner
+      push @inner_select, "$colsel_sql AS $quoted_alias";
 
-      my ($table, $orig_colname) = ( $selected_col =~ / (?: (.+) $name_sep )? ([^$name_sep]+) $ /x );
-      $new_colname = $self->_quote ("${table}__${orig_colname}");
+      # push alias to outer
+      push @outer_select, $quoted_alias;
 
-      $select =~ s/(\Q$quoted_col\E|\Q$selected_col\E)/"$1 AS $new_colname"/e;
+      # Any aliasing accumulated here will be considered
+      # both for inner and outer adjustments of ORDER BY
+      $self->__record_alias (
+        \%col_aliases,
+        $quoted_alias,
+        $colsel_arg,
+        $table ? $orig_colname : undef,
+      );
+    }
 
-      # record qualified name if available (should be)
-      $col_index{$selected_col} = $new_colname if $table;
+    # otherwise just leave things intact inside, and use the abbreviated one outside
+    # (as we do not have table names anymore)
+    else {
+      push @inner_select, $colsel_sql;
 
-      # record unqialified name, undef if a duplicate is found
-      if (exists $col_index{$orig_colname}) {
-        $col_index{$orig_colname} = undef;
-      }
-      else {
-        $col_index{$orig_colname} = $new_colname;
-      }
+      my $outer_quoted = $self->_quote ($orig_colname);  # it was not a duplicate so should just work
+      push @outer_select, $outer_quoted;
+      $self->__record_alias (
+        \%outer_col_aliases,
+        $outer_quoted,
+        $colsel_arg,
+        $table ? $orig_colname : undef,
+      );
     }
-
-    push @outer_select, $new_colname;
   }
 
   my $outer_select = join (', ', @outer_select );
+  my $inner_select = join (', ', @inner_select );
 
+  %outer_col_aliases = (%outer_col_aliases, %col_aliases);
 
   # deal with order
   croak '$order supplied to SQLAHacks limit emulators must be a hash'
@@ -167,41 +213,48 @@
   my $req_order = [ $self->_order_by_chunks ($order->{order_by}) ];
   my $limit_order = [ @$req_order ? @$req_order : $self->_order_by_chunks ($order->{_virtual_order_by}) ];
 
+  my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
+  my $order_by_requested = $self->_order_by ($req_order);
 
-  # normalize all column names in order by
-  # no copies, just aliasing ($_)
-  for ($req_order, $limit_order) {
-    for ( @{$_ || []} ) {
-      $_ = $col_index{$_} if $col_index{$_};
+  # we can't really adjust the order_by columns, as introspection is lacking
+  # resort to simple substitution
+  for my $col (keys %outer_col_aliases) {
+    for ($order_by_requested, $order_by_outer) {
+      $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
     }
   }
+  for my $col (keys %col_aliases) {
+    $order_by_inner =~ s/\s+$col\s+/$col_aliases{$col}/g;
+  }
 
 
   # generate the rest
   delete $order->{$_} for qw/order_by _virtual_order_by/;
   my $grpby_having = $self->_order_by ($order);
 
-  my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
 
-  my $last = $rows + $offset;
+  my $inner_lim = $rows + $offset;
 
-  $sql = <<"SQL";
+  my $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
 
+  if ($offset) {
+    $sql = <<"SQL";
+
     SELECT TOP $rows $outer_select FROM
     (
-      SELECT TOP $last $select $sql $grpby_having $order_by_inner
+      $sql
     ) AS inner_sel
     $order_by_outer
 SQL
 
-  if (@$req_order) {
-    my $order_by_requested = $self->_order_by ($req_order);
+  }
 
+  if ($order_by_requested) {
     $sql = <<"SQL";
 
-  SELECT $outer_select FROM
-  ( $sql ) AS outer_sel
-  $order_by_requested;
+    SELECT $outer_select FROM
+      ( $sql ) AS outer_sel
+    $order_by_requested;
 SQL
 
   }
@@ -209,8 +262,29 @@
   return $sql;
 }
 
+# action at a distance to shorten Top code above
+sub __record_alias {
+  my ($self, $register, $alias, $fqcol, $col) = @_;
 
+  # record qualified name
+  $register->{$fqcol} = $alias;
+  $register->{$self->_quote($fqcol)} = $alias;
 
+  return unless $col;
+
+  # record unqialified name, undef (no adjustment) if a duplicate is found
+  if (exists $register->{$col}) {
+    $register->{$col} = undef;
+  }
+  else {
+    $register->{$col} = $alias;
+  }
+
+  $register->{$self->_quote($col)} = $register->{$col};
+}
+
+
+
 # While we're at it, this should make LIMIT queries more efficient,
 #  without digging into things too deeply
 sub _find_syntax {

Modified: DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/Storage/DBI.pm	2009-06-20 08:16:02 UTC (rev 6733)
+++ DBIx-Class/0.08/branches/mssql_top_fixes/lib/DBIx/Class/Storage/DBI.pm	2009-06-20 08:34:42 UTC (rev 6734)
@@ -1229,7 +1229,12 @@
   my ($self, $ident, $select, $where, $attrs) = @_;
 
   my $sql_maker = $self->sql_maker;
-  $sql_maker->{_dbic_rs_attrs} = $attrs;
+  $sql_maker->{_dbic_rs_attrs} = {
+    %$attrs,
+    select => $select,
+    from => $ident,
+    where => $where,
+  };
 
   my $alias2source = $self->_resolve_ident_sources ($ident);
 
@@ -1289,17 +1294,17 @@
 sub _adjust_select_args_for_limited_prefetch {
   my ($self, $from, $select, $where, $attrs) = @_;
 
-  if ($attrs->{group_by} and @{$attrs->{group_by}}) {
-    $self->throw_exception ('Prefetch with limit (rows/offset) is not supported on resultsets with a group_by attribute');
+  if ($attrs->{group_by} && @{$attrs->{group_by}}) {
+    $self->throw_exception ('has_many prefetch with limit (rows/offset) is not supported on grouped resultsets');
   }
 
-  $self->throw_exception ('Prefetch with limit (rows/offset) is not supported on resultsets with a custom from attribute')
+  $self->throw_exception ('has_many prefetch with limit (rows/offset) is 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/;
-  delete $sub_attrs->{$_} for qw/for collapse select order_by/;
+  delete $sub_attrs->{$_} for qw/for collapse select as order_by/;
 
   my $alias = $attrs->{alias};
 
@@ -1314,7 +1319,6 @@
     ];
   }
 
-
   # mangle the head of the {from}
   my $self_ident = shift @$from;
 

Modified: DBIx-Class/0.08/branches/mssql_top_fixes/t/746mssql.t
===================================================================
--- DBIx-Class/0.08/branches/mssql_top_fixes/t/746mssql.t	2009-06-20 08:16:02 UTC (rev 6733)
+++ DBIx-Class/0.08/branches/mssql_top_fixes/t/746mssql.t	2009-06-20 08:34:42 UTC (rev 6734)
@@ -12,7 +12,7 @@
 
 plan tests => 19;
 
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1});
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
 
 {
   no warnings 'redefine';
@@ -90,7 +90,7 @@
 
 CREATE TABLE Owners (
    id INT IDENTITY (1, 1) NOT NULL,
-   [name] VARCHAR(100),
+   name VARCHAR(100),
 )
 
 SQL
@@ -136,26 +136,25 @@
 #
 
 {
-  # try a ->has_many direction (due to a 'multi' accessor the select/group_by group is collapsed)
+  # try a ->has_many direction (group_by is not possible on has_many with limit)
   my $owners = $schema->resultset ('Owners')->search ({
       'books.id' => { '!=', undef }
     }, {
       prefetch => 'books',
-      distinct => 1,
       order_by => 'name',
       page     => 2,
-      rows     => 5,
+      rows     => 3,
     });
 
-  is ($owners->all, 3, 'Prefetched grouped search returns correct number of rows');
-  is ($owners->count, 3, 'Prefetched grouped search returns correct count');
+  is ($owners->all, 3, 'has_many prefetch returns correct number of rows');
+  is ($owners->count, 3, 'has-many prefetch returns correct count');
 
-  # try a ->belongs_to direction (no select collapse)
+  # try a ->belongs_to direction (no select collapse, group_by should work)
   my $books = $schema->resultset ('BooksInLibrary')->search ({
       'owner.name' => 'wiggle'
     }, {
+      distinct => 1,
       prefetch => 'owner',
-      distinct => 1,
       order_by => 'name',
       rows     => 5,
     });
@@ -164,6 +163,7 @@
   is ($books->page(1)->all, 1, 'Prefetched grouped search returns correct number of rows');
   is ($books->page(1)->count, 1, 'Prefetched grouped search returns correct count');
 
+  #
   is ($books->page(2)->all, 0, 'Prefetched grouped search returns correct number of rows');
   is ($books->page(2)->count, 0, 'Prefetched grouped search returns correct count');
 




More information about the Bast-commits mailing list