X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=a454cd5f6948f8ef6bf8691a2b4bdc66b333724b;hb=1ab6145705e18535e27e538c87a11b9483121f1e;hp=e57e926c2d119a390b65ac1e6edc2fd7b0f1bcc6;hpb=6f4ddea126a20d67bc599a804d097ed8d3c086aa;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm
index e57e926..a454cd5 100644
--- a/lib/DBIx/Class/SQLAHacks.pm
+++ b/lib/DBIx/Class/SQLAHacks.pm
@@ -1,9 +1,31 @@
-
 package # Hide from PAUSE
-DBIx::Class::SQLAHacks; # Would merge upstream, but nate doesn't reply :(
-
+  DBIx::Class::SQLAHacks;
 
 use base qw/SQL::Abstract::Limit/;
+use strict;
+use warnings;
+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(@_);
@@ -18,7 +40,6 @@ sub new {
 }
 
 
-
 # Some databases (sqlite) do not handle multiple parenthesis
 # around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
 # is interpreted as x IN 1 or something similar.
@@ -67,16 +88,12 @@ sub _where_field_BETWEEN {
   return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
 }
 
-
-
-# DB2 is the only remaining DB using this. Even though we are not sure if
-# RowNumberOver is still needed here (should be part of SQLA) leave the 
-# code in place
+# Slow but ANSI standard Limit/Offset support. DB2 uses this
 sub _RowNumberOver {
   my ($self, $sql, $order, $rows, $offset ) = @_;
 
   $offset += 1;
-  my $last = $rows + $offset;
+  my $last = $rows + $offset - 1;
   my ( $order_by ) = $self->_order_by( $order );
 
   $sql = <<"SQL";
@@ -94,26 +111,58 @@ SQL
   return $sql;
 }
 
+# Crappy Top based Limit/Offset support. MSSQL uses this currently,
+# but may have to switch to RowNumberOver one day
+sub _Top {
+  my ( $self, $sql, $order, $rows, $offset ) = @_;
+
+  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)//;
+
+  $sql = <<"SQL";
+  SELECT * FROM
+  (
+    SELECT TOP $rows * FROM
+    (
+        SELECT TOP $last $sql $grpby_having $order_by_inner
+    ) AS foo
+    $order_by_outer
+  ) AS bar
+  $req_order
+
+SQL
+    return $sql;
+}
+
+
 
 # While we're at it, this should make LIMIT queries more efficient,
 #  without digging into things too deeply
-use Scalar::Util 'blessed';
 sub _find_syntax {
   my ($self, $syntax) = @_;
-  
-  # DB2 is the only remaining DB using this. Even though we are not sure if
-  # RowNumberOver is still needed here (should be part of SQLA) leave the 
-  # code in place
-  my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
-  if(ref($self) && $dbhname && $dbhname eq 'DB2') {
-    return 'RowNumberOver';
-  }
-  
-  $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
+  return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
 }
 
 sub select {
   my ($self, $table, $fields, $where, $order, @rest) = @_;
+
+  $self->{"${_}_bind"} = [] for (qw/having from order/);
+
   if (ref $table eq 'SCALAR') {
     $table = $$table;
   }
@@ -123,10 +172,9 @@ sub select {
   local $self->{rownum_hack_count} = 1
     if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
   @rest = (-1) unless defined $rest[0];
-  die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
+  croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
     # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
-  local $self->{having_bind} = [];
-  my ($sql, @ret) = $self->SUPER::select(
+  my ($sql, @where_bind) = $self->SUPER::select(
     $table, $self->_recurse_fields($fields), $where, $order, @rest
   );
   $sql .= 
@@ -138,13 +186,21 @@ sub select {
     ) :
     ''
   ;
-  return wantarray ? ($sql, @ret, @{$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, @_);
 }
 
@@ -186,60 +242,77 @@ sub _recurse_fields {
       } @$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 }"
+          );
+        }
+      }
       return $self->_sqlcase($func)
         .'( '.$self->_recurse_fields($fields->{$func}).' )';
     }
   }
   # Is the second check absolutely necessary?
   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
-    return $self->_bind_to_sql( $fields );
+    return $self->_fold_sqlbind( $fields );
   }
   else {
-    Carp::croak($ref . qq{ unexpected in _recurse_fields()})
+    croak($ref . qq{ unexpected in _recurse_fields()})
   }
 }
 
 sub _order_by {
-  my $self = shift;
-  my $ret = '';
-  my @extra;
-  if (ref $_[0] eq 'HASH') {
-    if (defined $_[0]->{group_by}) {
+  my ($self, $arg) = @_;
+
+  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 (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 = @{+shift};
-    $ret = $self->_sqlcase(' order by ')
-          .join(', ', map {
-                        my $r = $self->_order_by($_, @_);
-                        $r =~ s/^ ?ORDER BY //i;
-                        $r;
-                      } @order);
-  } else {
-    $ret = $self->SUPER::_order_by(@_);
+
+    return $ret;
+  }
+  else {
+    my ($sql, @bind) = $self->SUPER::_order_by ($arg);
+    push(@{$self->{order_bind}}, @bind);
+    return $sql;
   }
-  return $ret;
 }
 
 sub _order_directions {
   my ($self, $order) = @_;
-  $order = $order->{order_by} if ref $order eq 'HASH';
-  return $self->SUPER::_order_directions($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 {
@@ -285,19 +358,21 @@ sub _recurse_from {
   return join('', @sqlf);
 }
 
-sub _bind_to_sql {
-  my $self = shift;
-  my $arr  = shift;
-  my $sql = shift @$$arr;
-  $sql =~ s/\?/$self->_quote((shift @$$arr)->[1])/eg;
-  return $sql
+sub _fold_sqlbind {
+  my ($self, $sqlbind) = @_;
+
+  my @sqlbind = @$$sqlbind; # copy
+  my $sql = shift @sqlbind;
+  push @{$self->{from_bind}}, @sqlbind;
+
+  return $sql;
 }
 
 sub _make_as {
   my ($self, $from) = @_;
-  return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ 
-                        : ref $_ eq 'REF'    ? $self->_bind_to_sql($_) 
-                        : $self->_quote($_)) 
+  return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
+                        : ref $_ eq 'REF'    ? $self->_fold_sqlbind($_)
+                        : $self->_quote($_))
                        } reverse each %{$self->_skip_options($from)});
 }
 
@@ -316,8 +391,7 @@ sub _join_condition {
     for (keys %$cond) {
       my $v = $cond->{$_};
       if (ref $v) {
-        # XXX no throw_exception() in this package and croak() fails with strange results
-        Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
+        croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
             if ref($v) ne 'SCALAR';
         $j{$_} = $v;
       }
@@ -375,7 +449,9 @@ __END__
 
 =head1 NAME
 
-DBIx::Class::SQLAHacks - Things desired to be merged into SQL::Abstract
+DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
+and includes a number of DBIC-specific workarounds, not yet suitable for
+inclusion into SQLA proper.
 
 =head1 METHODS