X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBIHacks.pm;h=ce169170d84cdef6f69b2199111b969f56bd940e;hb=7f95ea9928d36f9bd41f3c3f45fcb84a62f35577;hp=e1722991e3e0701f679c84dff08568d6e1a51753;hpb=22485a7ea98d355acc7dc5432550d10dba0dee5e;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm
index e172299..ce16917 100644
--- a/lib/DBIx/Class/Storage/DBIHacks.pm
+++ b/lib/DBIx/Class/Storage/DBIHacks.pm
@@ -17,6 +17,7 @@ use List::Util 'first';
 use Scalar::Util 'blessed';
 use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize);
 use SQL::Abstract qw(is_plain_value is_literal_value);
+use DBIx::Class::Carp;
 use namespace::clean;
 
 #
@@ -416,7 +417,7 @@ sub _resolve_aliastypes_from_select_args {
   # generate sql chunks
   my $to_scan = {
     restricting => [
-      $sql_maker->_recurse_where ($attrs->{where}),
+      ($sql_maker->_recurse_where ($attrs->{where}))[0],
       $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }),
     ],
     grouping => [
@@ -986,6 +987,8 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion {
 sub _collapse_cond {
   my ($self, $where, $where_is_anded_array) = @_;
 
+  my $fin;
+
   if (! $where) {
     return;
   }
@@ -998,13 +1001,29 @@ sub _collapse_cond {
       my $chunk = shift @pieces;
 
       if (ref $chunk eq 'HASH') {
-        push @pairs, map { $_ => $chunk->{$_} } sort keys %$chunk;
+        for (sort keys %$chunk) {
+
+          # Match SQLA 1.79 behavior
+          if ($_ eq '') {
+            is_literal_value($chunk->{$_})
+              ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead'
+              : $self->throw_exception("Supplying an empty left hand side argument is not supported in hash-pairs")
+            ;
+          }
+
+          push @pairs, $_ => $chunk->{$_};
+        }
       }
       elsif (ref $chunk eq 'ARRAY') {
         push @pairs, -or => $chunk
           if @$chunk;
       }
       elsif ( ! length ref $chunk) {
+
+        # Match SQLA 1.79 behavior
+        $self->throw_exception("Supplying an empty left hand side argument is not supported in array-pairs")
+          if $where_is_anded_array and (! defined $chunk or $chunk eq '');
+
         push @pairs, $chunk, shift @pieces;
       }
       else {
@@ -1018,25 +1037,31 @@ sub _collapse_cond {
       or return;
 
     # Consolidate various @conds back into something more compact
-    my $fin;
-
     for my $c (@conds) {
       if (ref $c ne 'HASH') {
         push @{$fin->{-and}}, $c;
       }
       else {
         for my $col (sort keys %$c) {
-          if (exists $fin->{$col}) {
-            my ($l, $r) = ($fin->{$col}, $c->{$col});
 
-            (ref $_ ne 'ARRAY' or !@$_) and $_ = [ -and => $_ ] for ($l, $r);
-
-            if (@$l and @$r and $l->[0] eq $r->[0] and $l->[0] =~ /^\-and$/i) {
-              $fin->{$col} = [ -and => map { @$_[1..$#$_] } ($l, $r) ];
-            }
-            else {
-              $fin->{$col} = [ -and => $fin->{$col}, $c->{$col} ];
-            }
+          # consolidate all -and nodes
+          if ($col =~ /^\-and$/i) {
+            push @{$fin->{-and}},
+              ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}}
+            : ref $c->{$col} eq 'HASH' ? %{$c->{$col}}
+            : { $col => $c->{$col} }
+            ;
+          }
+          elsif ($col =~ /^\-/) {
+            push @{$fin->{-and}}, { $col => $c->{$col} };
+          }
+          elsif (exists $fin->{$col}) {
+            $fin->{$col} = [ -and => map {
+              (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i )
+                ? @{$_}[1..$#$_]
+                : $_
+              ;
+            } ($fin->{$col}, $c->{$col}) ];
           }
           else {
             $fin->{$col} = $c->{$col};
@@ -1044,44 +1069,18 @@ sub _collapse_cond {
         }
       }
     }
-
-    # unroll single-element -and nodes
-    if ( ref $fin->{-and} eq 'ARRAY' and @{$fin->{-and}} == 1 ) {
-      my $piece = (delete $fin->{-and})->[0];
-      if (ref $piece eq 'ARRAY') {
-        $fin->{-or} = $fin->{-or} ? [ $piece, $fin->{-or} ] : $piece;
-      }
-      elsif (! exists $fin->{''}) {
-        $fin->{''} = $piece;
-      }
-    }
-
-    # compress same-column conds found in $fin
-    for my $col ( keys %$fin ) {
-      next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') eq '-and';
-      my $val_bag = { map {
-        (! defined $_ )                   ? ( UNDEF => undef )
-      : ( ! ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ )
-      : ( ( 'SER_' . serialize $_ ) => $_ )
-      } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] };
-
-      if (keys %$val_bag == 1 ) {
-        ($fin->{$col}) = values %$val_bag;
-      }
-      else {
-        $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ];
-      }
-    }
-
-    return $fin;
   }
   elsif (ref $where eq 'ARRAY') {
-
     # we are always at top-level here, it is safe to dump empty *standalone* pieces
     my $fin_idx;
 
     for (my $i = 0; $i <= $#$where; $i++ ) {
 
+      # Match SQLA 1.79 behavior
+      $self->throw_exception(
+        "Supplying an empty left hand side argument is not supported in array-pairs"
+      ) if (! defined $where->[$i] or ! length $where->[$i]);
+
       my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' );
 
       if ($logic_mod) {
@@ -1092,32 +1091,122 @@ sub _collapse_cond {
         my $sub_elt = $self->_collapse_cond({ $logic_mod => $where->[$i] })
           or next;
 
-        $fin_idx->{ serialize $sub_elt } = $sub_elt;
+        my @keys = keys %$sub_elt;
+        if ( @keys == 1 and $keys[0] !~ /^\-/ ) {
+          $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt;
+        }
+        else {
+          $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt;
+        }
       }
       elsif (! length ref $where->[$i] ) {
-        $fin_idx->{"$where->[$i]_$i"} = $self->_collapse_cond({ @{$where}[$i, $i+1] }) || next;
+        my $sub_elt = $self->_collapse_cond({ @{$where}[$i, $i+1] })
+          or next;
+
+        $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt;
         $i++;
       }
       else {
-        $fin_idx->{ serialize $where->[$i] } = $self->_collapse_cond( $where->[$i] ) || next;
+        $fin_idx->{ "SER_" . serialize $where->[$i] } = $self->_collapse_cond( $where->[$i] ) || next;
       }
     }
 
-    return unless $fin_idx;
+    if (! $fin_idx) {
+      return;
+    }
+    elsif ( keys %$fin_idx == 1 ) {
+      $fin = (values %$fin_idx)[0];
+    }
+    else {
+      my @or;
+
+      # at this point everything is at most one level deep - unroll if needed
+      for (sort keys %$fin_idx) {
+        if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) {
+          my ($l, $r) = %{$fin_idx->{$_}};
+
+          if (
+            ref $r eq 'ARRAY'
+              and
+            (
+              ( @$r == 1 and $l =~ /^\-and$/i )
+                or
+              $l =~ /^\-or$/i
+            )
+          ) {
+            push @or, @$r
+          }
+
+          elsif (
+            ref $r eq 'HASH'
+              and
+            keys %$r == 1
+              and
+            $l =~ /^\-(?:and|or)$/i
+          ) {
+            push @or, %$r;
+          }
 
-    return ( keys %$fin_idx == 1 ) ? (values %$fin_idx)[0] : {
-      -or => [ map
-        { ref $fin_idx->{$_} eq 'HASH' ? %{$fin_idx->{$_}} : $fin_idx->{$_} }
-        sort keys %$fin_idx
-      ]
-    };
+          else {
+            push @or, $l, $r;
+          }
+        }
+        else {
+          push @or, $fin_idx->{$_};
+        }
+      }
+
+      $fin->{-or} = \@or;
+    }
   }
   else {
     # not a hash not an array
-    return { '' => $where };
+    $fin = { -and => [ $where ] };
   }
 
-  die 'should not get here';
+  # unroll single-element -and's
+  while (
+    $fin->{-and}
+      and
+    @{$fin->{-and}} < 2
+  ) {
+    my $and = delete $fin->{-and};
+    last if @$and == 0;
+
+    # at this point we have @$and == 1
+    if (
+      ref $and->[0] eq 'HASH'
+        and
+      ! grep { exists $fin->{$_} } keys %{$and->[0]}
+    ) {
+      $fin = {
+        %$fin, %{$and->[0]}
+      };
+    }
+    else {
+      $fin->{-and} = $and;
+      last;
+    }
+  }
+
+  # compress same-column conds found in $fin
+  for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) {
+    next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i;
+    my $val_bag = { map {
+      (! defined $_ )                          ? ( UNDEF => undef )
+    : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ )
+    : ( ( 'SER_' . serialize $_ ) => $_ )
+    } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] };
+
+    if (keys %$val_bag == 1 ) {
+      ($fin->{$col}) = values %$val_bag;
+    }
+    else {
+      $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ];
+    }
+  }
+
+  return keys %$fin ? $fin : ();
 }
 
 sub _collapse_cond_unroll_pairs {
@@ -1143,6 +1232,7 @@ sub _collapse_cond_unroll_pairs {
       if (ref $rhs eq 'HASH' and ! keys %$rhs) {
         # FIXME - SQLA seems to be doing... nothing...?
       }
+      # normalize top level -ident, for saner extract_fixed_condition_columns code
       elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) {
         push @conds, { $lhs => { '=', $rhs } };
       }
@@ -1150,7 +1240,7 @@ sub _collapse_cond_unroll_pairs {
         push @conds, { $lhs => $rhs->{-value} };
       }
       elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) {
-        if( is_literal_value $rhs->{'='}) {
+        if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) {
           push @conds, { $lhs => $rhs };
         }
         else {
@@ -1168,7 +1258,14 @@ sub _collapse_cond_unroll_pairs {
 
             my ($l, $r) = %$p;
 
-            push @conds, ( ! length ref $r or is_plain_value($r) )
+            push @conds, (
+              ! length ref $r
+                or
+              # the unroller recursion may return a '=' prepended value already
+              ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}
+                or
+              is_plain_value($r)
+            )
               ? { $l => $r }
               : { $l => { '=' => $r } }
             ;
@@ -1203,6 +1300,18 @@ sub _collapse_cond_unroll_pairs {
           push @conds, { $lhs => $rhs };
         }
       }
+      # unroll func + { -value => ... }
+      elsif (
+        ref $rhs eq 'HASH'
+          and
+        ( my ($subop) = keys %$rhs ) == 1
+          and
+        length ref ((values %$rhs)[0])
+          and
+        my $vref = is_plain_value( (values %$rhs)[0] )
+      ) {
+        push @conds, { $lhs => { $subop => $$vref } }
+      }
       else {
         push @conds, { $lhs => $rhs };
       }
@@ -1254,7 +1363,15 @@ sub _extract_fixed_condition_columns {
         }
       }
       # do not need to check for plain values - _collapse_cond did it for us
-      elsif(length ref $v->{'='} and is_literal_value($v->{'='}) ) {
+      elsif(
+        length ref $v->{'='}
+          and
+        (
+          ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} )
+            or
+          is_literal_value($v->{'='})
+        )
+       ) {
         $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='};
       }
     }