From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 7 Nov 2015 10:49:37 +0000 (+0100)
Subject: Add an explicit deduplication of identical condition in cond normalizer
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d6c13bfdf6656317fedbf7e9deeb450cf42efb5b;p=dbsrgits%2FDBIx-Class.git

Add an explicit deduplication of identical condition in cond normalizer

In order to make everything work consistently add a "lax serializer" based
on Data::Dumper, as Storable is sensitive to IV vs PVIV differences.

While at it tighten up the serialize/dump env in DBIC::_Util
---

diff --git a/lib/DBIx/Class/SQLMaker/Util.pm b/lib/DBIx/Class/SQLMaker/Util.pm
index e538843..f029e24 100644
--- a/lib/DBIx/Class/SQLMaker/Util.pm
+++ b/lib/DBIx/Class/SQLMaker/Util.pm
@@ -13,7 +13,71 @@ our @EXPORT_OK = qw(
 use DBIx::Class::Carp;
 use Carp 'croak';
 use SQL::Abstract qw( is_literal_value is_plain_value );
-use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION serialize dump_value );
+use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dump_value modver_gt_or_eq );
+
+# Can not use DBIx::Class::_Util::serialize as it is based on
+# Storable and leaks through differences between PVIV and an identical IV
+# Since SQLA itself is lossy in this regard (it does not make proper copies
+# for efficiency) one could end up in a situation where semantically
+# identical values aren't treated as such
+my $dd_obj;
+sub lax_serialize ($) {
+  my $dump_str = (
+    $dd_obj
+      ||=
+    do {
+      require Data::Dumper;
+
+      # Warnings without this on early loads under -w
+      # Why? Because fuck me, that's why :/
+      local $Data::Dumper::Indent = 0
+        unless defined $Data::Dumper::Indent;
+
+      # Make sure each option is spelled out with a value, so that
+      # global environment changes can not override any of these
+      # between two serialization calls
+      #
+      my $d = Data::Dumper->new([])
+        ->Indent('0')
+        ->Purity(0)
+        ->Pad('')
+        ->Useqq(0)
+        ->Terse(1)
+        ->Freezer('')
+        ->Toaster('')
+        ->Deepcopy(0)
+        ->Quotekeys(0)
+        ->Bless('bless')
+        ->Pair(' => ')
+        ->Maxdepth(0)
+        ->Useperl(0)
+        ->Sortkeys(1)
+        ->Deparse(0)
+      ;
+
+      # FIXME - this is kinda ridiculous - there ought to be a
+      # Data::Dumper->new_with_defaults or somesuch...
+      #
+      if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) {
+        $d->Sparseseen(1);
+
+        if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) {
+          $d->Maxrecurse(1000);
+
+          if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) {
+            $d->Trailingcomma(0);
+          }
+        }
+      }
+
+      $d;
+    }
+  )->Values([$_[0]])->Dump;
+
+  $dd_obj->Reset->Values([]);
+
+  $dump_str;
+}
 
 
 # Attempts to flatten a passed in SQLA condition as much as possible towards
@@ -81,7 +145,7 @@ sub normalize_sqla_condition {
         push @{$fin->{-and}}, $c;
       }
       else {
-        for my $col (sort keys %$c) {
+        for my $col (keys %$c) {
 
           # consolidate all -and nodes
           if ($col =~ /^\-and$/i) {
@@ -108,6 +172,17 @@ sub normalize_sqla_condition {
         }
       }
     }
+
+    # a deduplication (and sort) pass on all individual -and/-or members
+    for my $op (qw( -and -or )) {
+      if( @{ $fin->{$op} || [] } > 1 ) {
+        my $seen_chunks = { map {
+          lax_serialize($_) => $_
+        } @{$fin->{$op}} };
+
+        $fin->{$op} = [ @{$seen_chunks}{ sort keys %$seen_chunks } ];
+      }
+    }
   }
   elsif (ref $where eq 'ARRAY') {
     # we are always at top-level here, it is safe to dump empty *standalone* pieces
@@ -132,21 +207,21 @@ sub normalize_sqla_condition {
 
         my @keys = keys %$sub_elt;
         if ( @keys == 1 and $keys[0] !~ /^\-/ ) {
-          $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt;
+          $fin_idx->{ "COL_$keys[0]_" . lax_serialize $sub_elt } = $sub_elt;
         }
         else {
-          $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt;
+          $fin_idx->{ "SER_" . lax_serialize $sub_elt } = $sub_elt;
         }
       }
       elsif (! length ref $where->[$i] ) {
         my $sub_elt = normalize_sqla_condition({ @{$where}[$i, $i+1] })
           or next;
 
-        $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt;
+        $fin_idx->{ "COL_$where->[$i]_" . lax_serialize $sub_elt } = $sub_elt;
         $i++;
       }
       else {
-        $fin_idx->{ "SER_" . serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next;
+        $fin_idx->{ "SER_" . lax_serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next;
       }
     }
 
@@ -234,7 +309,7 @@ sub normalize_sqla_condition {
     my $val_bag = { map {
       (! defined $_ )                          ? ( UNDEF => undef )
     : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ )
-    : ( ( 'SER_' . serialize $_ ) => $_ )
+    : ( ( 'SER_' . lax_serialize $_ ) => $_ )
     } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] };
 
     if (keys %$val_bag == 1 ) {
@@ -414,7 +489,7 @@ sub extract_equality_conditions {
           is_literal_value($v->{'='})
         )
        ) {
-        $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='};
+        $vals->{ 'SER_' . lax_serialize $v->{'='} } = $v->{'='};
       }
     }
     elsif (
@@ -431,7 +506,7 @@ sub extract_equality_conditions {
         $vals->{
           ! defined $subval->{$c}                                        ? 'UNDEF'
         : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}"
-        : ( 'SER_' . serialize $subval->{$c} )
+        : ( 'SER_' . lax_serialize $subval->{$c} )
         } = $subval->{$c};
       }
     }
diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index ac3a937..7d4a407 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -352,7 +352,19 @@ sub set_subname ($$) {
 }
 
 sub serialize ($) {
+  # stable hash order
   local $Storable::canonical = 1;
+
+  # explicitly false - there is nothing sensible that can come out of
+  # an attempt at CODE serialization
+  local $Storable::Deparse;
+
+  # take no chances
+  local $Storable::forgive_me;
+
+  # FIXME
+  # A number of codepaths *expect* this to be Storable.pm-based so that
+  # the STORABLE_freeze hooks in the metadata subtree get executed properly
   nfreeze($_[0]);
 }
 
@@ -388,9 +400,20 @@ sub dump_value ($) {
         ->Deparse(1)
       ;
 
-      $d->Sparseseen(1) if modver_gt_or_eq (
-        'Data::Dumper', '2.136'
-      );
+      # FIXME - this is kinda ridiculous - there ought to be a
+      # Data::Dumper->new_with_defaults or somesuch...
+      #
+      if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) {
+        $d->Sparseseen(1);
+
+        if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) {
+          $d->Maxrecurse(1000);
+
+          if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) {
+            $d->Trailingcomma(1);
+          }
+        }
+      }
 
       $d;
     }
@@ -723,11 +746,10 @@ sub modver_gt_or_eq ($$) {
   croak "Nonsensical minimum version supplied"
     if ! defined $ver or $ver !~ $ver_rx;
 
-  no strict 'refs';
-  my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION
-    ? {}
-    : croak "$mod does not seem to provide a version (perhaps it never loaded)"
-  );
+  my $ver_cache = do {
+    no strict 'refs';
+    ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= {}
+  };
 
   ! defined $ver_cache->{$ver}
     and
@@ -736,6 +758,18 @@ sub modver_gt_or_eq ($$) {
     local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
       if SPURIOUS_VERSION_CHECK_WARNINGS;
 
+    # prevent captures by potential __WARN__ hooks or the like:
+    # there is nothing of value that can be happening here, and
+    # leaving a hook in-place can only serve to fail some test
+    local $SIG{__WARN__} if (
+      ! SPURIOUS_VERSION_CHECK_WARNINGS
+        and
+      $SIG{__WARN__}
+    );
+
+    croak "$mod does not seem to provide a version (perhaps it never loaded)"
+      unless $mod->VERSION;
+
     local $SIG{__DIE__} if $SIG{__DIE__};
     local $@;
     eval { $mod->VERSION($ver) } ? 1 : 0;
diff --git a/t/52leaks.t b/t/52leaks.t
index ae96a21..bd159a7 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -461,6 +461,15 @@ for my $addr (keys %$weak_registry) {
     delete $weak_registry->{$addr}
       unless $cleared->{bheos_pptiehinthashfieldhash}++;
   }
+  elsif (
+    $names =~ /^Data::Dumper/m
+      and
+    $weak_registry->{$addr}{stacktrace} =~ /\bDBIx::Class::SQLMaker::Util::lax_serialize\b/
+  ) {
+    # only clear one object of a specific behavior - more would indicate trouble
+    delete $weak_registry->{$addr}
+      unless $cleared->{dd_lax_serializer}++;
+  }
   elsif ($names =~ /^DateTime::TimeZone::UTC/m) {
     # DT is going through a refactor it seems - let it leak zones for now
     delete $weak_registry->{$addr};
diff --git a/t/search/stack_cond.t b/t/search/stack_cond.t
index 497b698..6989c6f 100644
--- a/t/search/stack_cond.t
+++ b/t/search/stack_cond.t
@@ -72,9 +72,7 @@ for my $c (
       SELECT me.title
         FROM cd me
       WHERE
-        ( genreid != 42 OR genreid IS NULL )
-          AND
-        ( genreid != 42 OR genreid IS NULL )
+        ( genreid IS NULL OR genreid != 42 )
           AND
         title != bar
           AND
@@ -85,7 +83,7 @@ for my $c (
         year $c->{sql}
     )",
     \@bind,
-    'Double condition correctly collapsed for steps' . dump_value \@query_steps,
+    'Double condition correctly collapsed for steps:' . join( '', map { "\n\t" . dump_value($_) } @query_steps ),
   );
 }
 
diff --git a/xt/extra/internals/sqla_condition_parsers.t b/xt/extra/internals/sqla_condition_parsers.t
index 14a2c31..98a76b0 100644
--- a/xt/extra/internals/sqla_condition_parsers.t
+++ b/xt/extra/internals/sqla_condition_parsers.t
@@ -34,6 +34,9 @@ my $num = bless( \do { my $foo = 69 }, 'DBICTest::SillyInt' );
 is($num, 69, 'test overloaded object is "sane"');
 is("$num", 69, 'test overloaded object is "sane"');
 
+my $AttUQoLtUaE = 42;
+my $PVIVmaker = $AttUQoLtUaE . '';
+
 my @tests = (
   {
     where => { artistid => 1, charfield => undef },
@@ -89,9 +92,9 @@ my @tests = (
   },
   {
     where => { -and => [ \'foo=bar',  [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'}, \'buzz=bozz' ] },
-    normalized => { -and => [ \'foo=bar', \'buzz=bozz' ], name => 'Caterwauler McCrae', artistid => $num },
+    normalized => { -and => [ \'buzz=bozz', \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num },
     sql =>            'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz',
-    normalized_sql => 'WHERE foo=bar AND buzz=bozz AND artistid = ? AND name = ?',
+    normalized_sql => 'WHERE buzz=bozz AND foo=bar AND artistid = ? AND name = ?',
     equality_extract => { name => 'Caterwauler McCrae', artistid => $num },
   },
   {
@@ -110,9 +113,8 @@ my @tests = (
   },
   {
     where => { artistid => { '=' => [ 1 ], }, charfield => { '=' => [ -AND => \'1', \['?',2] ] }, rank => { '=' => [ -OR => $num, $num ] } },
-    normalized => { artistid => 1, charfield => [-and => { '=' => \['?',2] }, { '=' => \'1' } ], rank => { '=' => [$num, $num] } },
+    normalized => { artistid => 1, charfield => [-and => { '=' => \'1' }, { '=' => \['?',2] } ], rank => { '=' => [$num, $num] } },
     sql =>            'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )',
-    normalized_sql => 'WHERE artistid = ? AND charfield = ? AND charfield = 1 AND ( rank = ? OR rank = ? )',
     equality_extract => { artistid => 1, charfield => UNRESOLVABLE_CONDITION },
   },
   {
@@ -135,10 +137,10 @@ my @tests = (
   (map { {
     where => $_,
     sql =>            'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)',
-    normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank != 42)',
+    normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank != 42) AND (artistid = ? OR charfield IS NULL OR rank = 13)',
     normalized => { -and => [
-      { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
       { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] },
+      { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
     ] },
     equality_extract => {},
     equality_considering_nulls_extract => {},
@@ -146,7 +148,7 @@ my @tests = (
 
     { -and => [
       -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ],
-      -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } },
+      -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \$AttUQoLtUaE } },
     ] },
 
     {
@@ -182,20 +184,34 @@ my @tests = (
   },
   {
     where => { -and => [
-      -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ],
-      -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \13 } },
-    ] },
-    normalized => { -and => [
-      { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
-      { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
+      -or => [ rank => { '=' => \$AttUQoLtUaE }, charfield => { '=' => undef }, artistid => 1 ],
+      -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \42 } },
     ] },
-    sql =>            'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 13)',
-    normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank = 13)',
+    normalized => {
+      -or => [ artistid => 1, charfield => undef, rank => { '=' => \42 } ],
+    },
+    sql =>            'WHERE (rank = 42 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 42)',
+    normalized_sql => 'WHERE artistid = ? OR charfield IS NULL OR rank = 42',
     equality_extract => {},
     equality_considering_nulls_extract => {},
   },
   {
     where => { -and => [
+      { -or => [ \42 ] },
+      { -and => [
+        { -or => [ \$AttUQoLtUaE ] },
+        { -or => [ \13 ] },
+      ] },
+    ] },
+    normalized => {
+      -and => [ \13, \42 ],
+    },
+    sql             => 'WHERE 42 AND 42 AND 13',
+    normalized_sql  => 'WHERE 13 AND 42',
+    equality_extract => {},
+  },
+  {
+    where => { -and => [
       -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ],
       -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } },
       -and => [ foo => { '=' => \1 }, bar => 2 ],
@@ -218,12 +234,12 @@ my @tests = (
       AND NOT foo = ?
     ',
     normalized_sql => 'WHERE
-          ( artistid = ? OR charfield IS NULL OR rank = 13 )
-      AND ( artistid = ? OR charfield IS NULL OR rank != 42 )
-      AND (EXISTS (SELECT 1))
+          (EXISTS (SELECT 1))
       AND (EXISTS (SELECT 2))
       AND NOT foo = ?
       AND NOT foo = ?
+      AND ( artistid = ? OR charfield IS NULL OR rank != 42 )
+      AND ( artistid = ? OR charfield IS NULL OR rank = 13 )
       AND bar = 4
       AND bar = ?
       AND foo = 1
@@ -231,12 +247,12 @@ my @tests = (
     ',
     normalized => {
       -and => [
-        { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
-        { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] },
         { -exists => \'(SELECT 1)' },
         { -exists => \'(SELECT 2)' },
-        { -not => { foo => 69 } },
         { -not => { foo => 42 } },
+        { -not => { foo => 69 } },
+        { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] },
+        { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] },
       ],
       foo => [ -and => { '=' => \1 }, 3 ],
       bar => [ -and => { '=' => \4 }, 2 ],
@@ -418,13 +434,14 @@ my @tests = (
         \'baz = ber',
       ],
     },
-    sql => 'WHERE foo = bar AND baz = ber',
     normalized => {
       -and => [
-        \'foo = bar',
         \'baz = ber',
+        \'foo = bar',
       ],
     },
+    sql            => 'WHERE foo = bar AND baz = ber',
+    normalized_sql => 'WHERE baz = ber AND foo = bar',
     equality_extract => {},
   },
   {
@@ -435,14 +452,15 @@ my @tests = (
         x => { -ident => 'y' },
       ],
     },
-    sql => 'WHERE foo = bar AND baz = ber AND x = y',
     normalized => {
       -and => [
-        \'foo = bar',
         \'baz = ber',
+        \'foo = bar',
       ],
       x => { '=' => { -ident => 'y' } }
     },
+    sql            => 'WHERE foo = bar AND baz = ber AND x = y',
+    normalized_sql => 'WHERE baz = ber AND foo = bar AND x = y',
     equality_extract => { x => { -ident => 'y' } },
   },
 );