X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=a454cd5f6948f8ef6bf8691a2b4bdc66b333724b;hb=088476d4e792951b2e11229d168636dff027e84d;hp=f9a5675c839a13f0bc4d6e52cf26075c0e932bc4;hpb=158277126c0e818bcb036f8594acb4bdf0d73202;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm
index f9a5675..a454cd5 100644
--- a/lib/DBIx/Class/SQLAHacks.pm
+++ b/lib/DBIx/Class/SQLAHacks.pm
@@ -4,8 +4,28 @@ package # Hide from PAUSE
 use base qw/SQL::Abstract::Limit/;
 use strict;
 use warnings;
-use Carp::Clan qw/^DBIx::Class/;
-use Scalar::Util();
+use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
+
+BEGIN {
+  # reinstall the carp()/croak() functions imported into SQL::Abstract
+  # as Carp and Carp::Clan do not like each other much
+  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/) {
+        __PACKAGE__->can($f)->(@_);
+      }
+      else {
+        $orig->(@_);
+      }
+    }
+  }
+}
 
 sub new {
   my $self = shift->SUPER::new(@_);
@@ -99,11 +119,17 @@ sub _Top {
   croak '$order supplied to SQLAHacks limit emulators must be a hash'
     if (ref $order ne 'HASH');
 
+  $order = { %$order }; #copy
+
   my $last = $rows + $offset;
 
   my $req_order = $self->_order_by ($order->{order_by});
+
   my $limit_order = $req_order ? $order->{order_by} : $order->{_virtual_order_by};
 
+  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);
 
   $sql =~ s/^\s*(SELECT|select)//;
@@ -113,7 +139,7 @@ sub _Top {
   (
     SELECT TOP $rows * FROM
     (
-        SELECT TOP $last $sql $order_by_inner
+        SELECT TOP $last $sql $grpby_having $order_by_inner
     ) AS foo
     $order_by_outer
   ) AS bar
@@ -134,8 +160,8 @@ sub _find_syntax {
 
 sub select {
   my ($self, $table, $fields, $where, $order, @rest) = @_;
-  local $self->{having_bind} = [];
-  local $self->{from_bind} = [];
+
+  $self->{"${_}_bind"} = [] for (qw/having from order/);
 
   if (ref $table eq 'SCALAR') {
     $table = $$table;
@@ -160,13 +186,21 @@ sub select {
     ) :
     ''
   ;
-  return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}) : $sql;
+  return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
 }
 
 sub insert {
   my $self = shift;
   my $table = shift;
   $table = $self->_quote($table) unless ref($table);
+
+  # SQLA will emit INSERT INTO $table ( ) VALUES ( )
+  # which is sadly understood only by MySQL. Change default behavior here,
+  # until SQLA2 comes with proper dialect support
+  if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
+    return "INSERT INTO ${table} DEFAULT VALUES"
+  }
+
   $self->SUPER::insert($table, @_);
 }
 
@@ -239,96 +273,46 @@ sub _recurse_fields {
 }
 
 sub _order_by {
-  my $self = shift;
-  my $ret = '';
-  my @extra;
-  if (ref $_[0] eq 'HASH') {
+  my ($self, $arg) = @_;
 
-    if (defined $_[0]->{group_by}) {
+  if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
+
+    my $ret = '';
+
+    if (defined $arg->{group_by}) {
       $ret = $self->_sqlcase(' group by ')
-        .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
+        .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
     }
 
-    if (defined $_[0]->{having}) {
-      my $frag;
-      ($frag, @extra) = $self->_recurse_where($_[0]->{having});
-      push(@{$self->{having_bind}}, @extra);
+    if (defined $arg->{having}) {
+      my ($frag, @bind) = $self->_recurse_where($arg->{having});
+      push(@{$self->{having_bind}}, @bind);
       $ret .= $self->_sqlcase(' having ').$frag;
     }
 
-    if (defined $_[0]->{order_by}) {
-      $ret .= $self->_order_by($_[0]->{order_by});
+    if (defined $arg->{order_by}) {
+      my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
+      push(@{$self->{order_bind}}, @bind);
+      $ret .= $frag;
     }
 
-    if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
-      return $self->SUPER::_order_by($_[0]);
-    }
-
-  } elsif (ref $_[0] eq 'SCALAR') {
-    $ret = $self->_sqlcase(' order by ').${ $_[0] };
-  } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
-    my @order = map {
-      my $r = $self->_order_by($_, @_);
-      $r =~ s/^ ?ORDER BY //i;
-      $r || ();
-    } @{+shift};
-
-    $ret = $self->_sqlcase(' order by ') . join(', ', @order) if @order;
-
-  } else {
-    $ret = $self->SUPER::_order_by(@_);
-  }
-  return $ret;
-}
-
-sub _order_directions {
-  my ($self, $order) = @_;
-  return $self->SUPER::_order_directions( $self->_resolve_order($order) );
-}
-
-sub _resolve_order {
-  my ($self, $order) = @_;
-
-  if (ref $order eq 'HASH') {
-    $order = [$self->_resolve_order_hash($order)];
+    return $ret;
   }
-  elsif (ref $order eq 'ARRAY') {
-    $order = [map {
-      if (ref ($_) eq 'SCALAR') {
-        $$_
-      }
-      elsif (ref ($_) eq 'HASH') {
-        $self->_resolve_order_hash($_)
-      }
-      else {
-        $_
-      }
-    }  @$order];
+  else {
+    my ($sql, @bind) = $self->SUPER::_order_by ($arg);
+    push(@{$self->{order_bind}}, @bind);
+    return $sql;
   }
-
-  return $order;
 }
 
-sub _resolve_order_hash {
+sub _order_directions {
   my ($self, $order) = @_;
-  my @new_order;
-  foreach my $key (keys %{ $order }) {
-    if ($key =~ /^-(desc|asc)/i ) {
-      my $direction = $1;
-      my $type = ref $order->{ $key };
-      if ($type eq 'ARRAY') {
-        push @new_order, map( "$_ $direction", @{ $order->{ $key } } );
-      } elsif (!$type) {
-        push @new_order, "$order->{$key} $direction";
-      } else {
-        croak "hash order_by can only contain Scalar or Array, not $type";
-      }
-    } else {
-      croak "$key is not a valid direction, use -asc or -desc";
-    }
-  }
 
-  return @new_order;
+  # strip bind values - none of the current _order_directions users support them
+  return $self->SUPER::_order_directions( [ map
+    { ref $_ ? $_->[0] : $_ }
+    $self->_order_by_chunks ($order)
+  ]);
 }
 
 sub _table {