Merge 'order_by_refactor' into 'trunk'
Peter Rabbitson [Mon, 1 Jun 2009 14:41:49 +0000 (14:41 +0000)]
Changes
Makefile.PL
lib/DBIx/Class/SQLAHacks.pm
t/95sql_maker.t
t/bind/attribute.t [moved from t/47bind_attribute.t with 100% similarity]
t/bind/bindtype_columns.t [moved from t/bindtype_columns.t with 100% similarity]
t/bind/order_by.t [new file with mode: 0644]

diff --git a/Changes b/Changes
index 9c7b91e..99c933a 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,9 +1,17 @@
 Revision history for DBIx::Class
 
+        - order_by now can take \[$sql, @bind] as in
+          order_by => { -desc => \['colA LIKE ?', 'somestring'] }
+        - SQL::Abstract errors are now properly croak()ed with the
+          correct trace
         - populate() now properly reports the dataset slice in case of
           an exception
         - fixed corner case when populate() erroneously falls back to
           create()
+        - order_by now can take \[$sql, @bind] as in
+          order_by => { -desc => \['colA LIKE ?', 'somestring'] }
+        - SQL::Abstract errors are now properly croak()ed with the
+          correct trace
 
 0.08103 2009-05-26 19:50:00 (UTC)
         - Multiple $resultset -> count/update/delete fixes. Now any
index 8ea186c..e0d90c4 100644 (file)
@@ -11,7 +11,7 @@ all_from 'lib/DBIx/Class.pm';
 
 requires 'DBD::SQLite'              => 1.25;
 requires 'Data::Page'               => 2.00;
-requires 'SQL::Abstract'            => 1.55;
+requires 'SQL::Abstract'            => 1.56;
 requires 'SQL::Abstract::Limit'     => 0.13;
 requires 'Class::C3::Componentised' => 1.0005;
 requires 'Carp::Clan'               => 6.0;
index 2aca425..c0b9937 100644 (file)
@@ -4,7 +4,28 @@ package # Hide from PAUSE
 use base qw/SQL::Abstract::Limit/;
 use strict;
 use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+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(@_);
@@ -103,6 +124,7 @@ sub _Top {
   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/;
@@ -138,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;
@@ -164,7 +186,7 @@ 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 {
@@ -243,96 +265,46 @@ sub _recurse_fields {
 }
 
 sub _order_by {
-  my $self = shift;
-  my $ret = '';
-  my @extra;
-  if (ref $_[0] eq 'HASH') {
+  my ($self, $arg) = @_;
+
+  if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
 
-    if (defined $_[0]->{group_by}) {
+    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 (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
-      return $self->SUPER::_order_by($_[0]);
+    if (defined $arg->{order_by}) {
+      my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
+      push(@{$self->{order_bind}}, @bind);
+      $ret .= $frag;
     }
 
-  } 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;
   }
-  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)];
-  }
-  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 {
index 48f66ac..d99d201 100644 (file)
@@ -2,16 +2,12 @@ use strict;
 use warnings;
 
 use Test::More;
+use Test::Exception;
 
 use lib qw(t/lib);
 use DBIC::SqlMakerTest;
 
-BEGIN {
-    eval "use DBD::SQLite";
-    plan $@
-        ? ( skip_all => 'needs DBD::SQLite for testing' )
-        : ( tests => 3 );
-}
+plan tests => 4;
 
 use_ok('DBICTest');
 
@@ -52,3 +48,9 @@ my $sql_maker = $schema->storage->sql_maker;
     'sql_maker passes arrayrefs in update'
   );
 }
+
+# Make sure the carp/croak override in SQLA works (via SQLAHacks)
+my $file = __FILE__;
+throws_ok (sub {
+  $schema->resultset ('Artist')->search ({}, { order_by => { -asc => 'stuff', -desc => 'staff' } } )->as_query;
+}, qr/$file/, 'Exception correctly croak()ed');
similarity index 100%
rename from t/47bind_attribute.t
rename to t/bind/attribute.t
diff --git a/t/bind/order_by.t b/t/bind/order_by.t
new file mode 100644 (file)
index 0000000..7a8bce6
--- /dev/null
@@ -0,0 +1,106 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema;
+
+my $rs = $schema->resultset('FourKeys');
+
+sub test_order {
+
+  TODO: {
+    my $args = shift;
+
+    local $TODO = "Not implemented" if $args->{todo};
+
+    lives_ok {
+      is_same_sql_bind(
+        $rs->search(
+            { foo => 'bar' },
+            {
+                order_by => $args->{order_by},
+                having =>
+                  [ { read_count => { '>' => 5 } }, \[ 'read_count < ?', 8 ] ]
+            }
+          )->as_query,
+        "(
+          SELECT me.foo, me.bar, me.hello, me.goodbye, me.sensors, me.read_count 
+          FROM fourkeys me 
+          WHERE ( foo = ? ) 
+          HAVING read_count > ? OR read_count < ?
+          ORDER BY $args->{order_req}
+        )",
+        [
+            [qw(foo bar)],
+            [qw(read_count 5)],
+            8,
+            $args->{bind}
+              ? @{ $args->{bind} }
+              : ()
+        ],
+      );
+    };
+    fail('Fail the unfinished is_same_sql_bind') if $@;
+  }
+}
+
+my @tests = (
+    {
+        order_by  => \'foo DESC',
+        order_req => 'foo DESC',
+        bind      => [],
+    },
+    {
+        order_by  => { -asc => 'foo' },
+        order_req => 'foo ASC',
+        bind      => [],
+    },
+    {
+        order_by  => { -desc => \[ 'colA LIKE ?', 'test' ] },
+        order_req => 'colA LIKE ? DESC',
+        bind      => [qw(test)],
+    },
+    {
+        order_by  => \[ 'colA LIKE ? DESC', 'test' ],
+        order_req => 'colA LIKE ? DESC',
+        bind      => [qw(test)],
+    },
+    {
+        order_by => [
+            { -asc  => \['colA'] },
+            { -desc => \[ 'colB LIKE ?', 'test' ] },
+            { -asc  => \[ 'colC LIKE ?', 'tost' ] }
+        ],
+        order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
+        bind      => [qw(test tost)],
+    },
+
+    # (mo) this would be really really nice!
+    # (ribasushi) I don't think so, not writing it - patches welcome
+    {
+        order_by => [
+            { -asc  => 'colA' },
+            { -desc => { colB => { 'LIKE' => 'test' } } },
+            { -asc  => { colC => { 'LIKE' => 'tost' } } }
+        ],
+        order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
+        bind      => [ [ colB => 'test' ], [ colC => 'tost' ] ],      # ???
+        todo => 1,
+    },
+    {
+        order_by  => { -desc => { colA  => { LIKE  => 'test' } } },
+        order_req => 'colA LIKE ? DESC',
+        bind      => [qw(test)],
+        todo => 1,
+    },
+);
+
+plan( tests => scalar @tests * 2 );
+
+test_order($_) for @tests;
+