Merge 'trunk' into 'mssql_top_fixes'

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / SQLAHacks.pm

diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm
index ba89264..2698ab7 100644 (file)
--- a/lib/DBIx/Class/SQLAHacks.pm
+++ b/lib/DBIx/Class/SQLAHacks.pm
@@ -12,12 +12,13 @@ BEGIN {
   no warnings qw/redefine/;
   no strict qw/refs/;
   for my $f (qw/carp croak/) {
+
     my $orig = \&{"SQL::Abstract::$f"};
     *{"SQL::Abstract::$f"} = sub {
 
       local $Carp::CarpLevel = 1;   # even though Carp::Clan ignores this, $orig will not
 
-      if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+\(\) called/) {
+      if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
         __PACKAGE__->can($f)->(@_);
       }
       else {
@@ -210,8 +211,12 @@ sub _Top {
 
   $order = { %$order }; #copy
 
-  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 $req_order = $order->{order_by};
+  my $limit_order =
+    scalar $self->_order_by_chunks ($req_order) # examine normalized version, collapses nesting
+      ? $req_order
+      : $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);
@@ -225,7 +230,6 @@ sub _Top {
     return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
   }
 
-
   # we can't really adjust the order_by columns, as introspection is lacking
   # resort to simple substitution
   for my $col (keys %outer_col_aliases) {
@@ -237,6 +241,7 @@ sub _Top {
     $order_by_inner =~ s/\s+$col\s+/$col_aliases{$col}/g;
   }
 
+
   my $inner_lim = $rows + $offset;
 
   $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
@@ -247,7 +252,7 @@ sub _Top {
     SELECT TOP $rows $outer_select FROM
     (
       $sql
-    ) AS inner_sel
+    ) AS me
     $order_by_outer
 SQL
 
@@ -257,7 +262,7 @@ SQL
     $sql = <<"SQL";
 
     SELECT $outer_select FROM
-      ( $sql ) AS outer_sel
+      ( $sql ) AS me
     $order_by_requested;
 SQL
 
@@ -276,7 +281,7 @@ sub __record_alias {
 
   return unless $col;
 
-  # record unqialified name, undef (no adjustment) if a duplicate is found
+  # record unqualified name, undef (no adjustment) if a duplicate is found
   if (exists $register->{$col}) {
     $register->{$col} = undef;
   }
@@ -377,28 +382,39 @@ sub _recurse_fields {
           ? ' AS col'.$self->{rownum_hack_count}++
           : '')
       } @$fields);
-  } elsif ($ref eq 'HASH') {
-    foreach my $func (keys %$fields) {
-      if ($func eq 'distinct') {
-        my $_fields = $fields->{$func};
-        if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
-          croak (
-            'The select => { distinct => ... } syntax is not supported for multiple columns.'
-           .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
-           .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
-          );
-        }
-        else {
-          $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
-          carp (
-            'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
-           ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
-          );
-        }
+  }
+  elsif ($ref eq 'HASH') {
+    my %hash = %$fields;
+    my ($select, $as);
+
+    if ($hash{-select}) {
+      $select = $self->_recurse_fields (delete $hash{-select});
+      $as = $self->_quote (delete $hash{-as});
+    }
+    else {
+      my ($func, $args) = each %hash;
+      delete $hash{$func};
+
+      if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
+        croak (
+          'The select => { distinct => ... } syntax is not supported for multiple columns.'
+         .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
+         .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
+        );
       }
-      return $self->_sqlcase($func)
-        .'( '.$self->_recurse_fields($fields->{$func}).' )';
+      $select = sprintf ('%s( %s )',
+        $self->_sqlcase($func),
+        $self->_recurse_fields($args)
+      );
     }
+
+    # there should be nothing left
+    if (keys %hash) {
+      croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
+    }
+
+    $select .= " AS $as" if $as;
+    return $select;
   }
   # Is the second check absolutely necessary?
   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
@@ -416,9 +432,8 @@ sub _order_by {
 
     my $ret = '';
 
-    if (defined $arg->{group_by}) {
-      $ret = $self->_sqlcase(' group by ')
-        .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
+    if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
+      $ret = $self->_sqlcase(' group by ') . $g;
     }
 
     if (defined $arg->{having}) {