make sure extraclauses doesn't kill already extant overrides for from

[scpubgit/Q-Branch.git] / lib / SQL / Abstract / Test.pm

diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm
index 5a82064..e163f2c 100644 (file)
--- a/lib/SQL/Abstract/Test.pm
+++ b/lib/SQL/Abstract/Test.pm
@@ -7,6 +7,42 @@ use Test::Builder;
 use Test::Deep ();
 use SQL::Abstract::Tree;
 
+{
+  my $class;
+  if ($class = $ENV{SQL_ABSTRACT_TEST_AGAINST}) {
+    my $mod = join('/', split '::', $class).".pm";
+    require $mod;
+    eval qq{sub SQL::Abstract () { "\Q${class}\E" }; 1}
+      or die "Failed to create const sub for ${class}: $@";
+  }
+  if ($ENV{SQL_ABSTRACT_TEST_EXPAND_STABILITY}) {
+    $class ||= do { require SQL::Abstract; 'SQL::Abstract' };
+    my $orig = $class->can('expand_expr');
+    require Data::Dumper::Concise;
+    my $wrapped = sub {
+      my ($self, @args) = @_;
+      my $e1 = $self->$orig(@args);
+      return $e1 if our $Stab_Check_Rec;
+      local $Stab_Check_Rec = 1;
+      my $e2 = $self->$orig($e1);
+      my ($d1, $d2) = map Data::Dumper::Concise::Dumper($_), $e1, $e2;
+      (our $tb)->is_eq(
+        $d2, $d1,
+        'expand_expr stability ok'
+      ) or do {
+        require Path::Tiny;
+        Path::Tiny->new('e1')->spew($d1);
+        Path::Tiny->new('e2')->spew($d2);
+        system('diff -u e1 e2 1>&2');
+        die "Differences between e1 and e2, bailing out";
+      };
+      return $e1;
+    };
+    no strict 'refs'; no warnings 'redefine';
+    *{"${class}::expand_expr"} = $wrapped;
+  }
+}
+
 our @EXPORT_OK = qw(
   is_same_sql_bind is_same_sql is_same_bind
   eq_sql_bind eq_sql eq_bind dumper diag_where
@@ -28,7 +64,7 @@ sub _unpack_arrayrefref {
   for (1,2) {
     my $chunk = shift @_;
 
-    if ( ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY' ) {
+    if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
       my ($sql, @bind) = @$$chunk;
       push @args, ($sql, \@bind);
     }
@@ -112,14 +148,19 @@ sub dumper {
 }
 
 sub diag_where{
-  $tb->diag( "Search term:\n" . &dumper );
+  $tb->diag("Search term:\n" . &dumper);
 }
 
 sub _sql_differ_diag {
   my $sql1 = shift || '';
   my $sql2 = shift || '';
 
-  $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
+  if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
+    my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
+    $_ = $sqlat->format($_) for ($sql1, $sql2);
+  }
+
+  $tb->${\($tb->in_todo ? 'note' : 'diag')} (
        "SQL expressions differ\n"
       ." got: $sql1\n"
       ."want: $sql2\n"
@@ -130,7 +171,7 @@ sub _sql_differ_diag {
 sub _bind_differ_diag {
   my ($bind_ref1, $bind_ref2) = @_;
 
-  $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
+  $tb->${\($tb->in_todo ? 'note' : 'diag')} (
     "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
   );
 }
@@ -159,8 +200,8 @@ sub _eq_sql {
   my ($left, $right) = @_;
 
   # one is defined the other not
-  if ( (defined $left) xor (defined $right) ) {
-    $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
+  if ((defined $left) xor (defined $right)) {
+    $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
     return 0;
   }
 
@@ -176,14 +217,14 @@ sub _eq_sql {
 
   # one is empty
   if (@$left == 0 or @$right == 0) {
-    $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
+    $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
     return 0;
   }
 
   # one is a list, the other is an op with a list
   elsif (ref $left->[0] xor ref $right->[0]) {
     $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
-      { ref $_ ? $sqlat->unparse ($_) : $_ }
+      { ref $_ ? $sqlat->unparse($_) : $_ }
       ($left->[0], $right->[0], $left, $right)
     );
     return 0;
@@ -196,7 +237,7 @@ sub _eq_sql {
         if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
           $sql_differ ||= '';
           $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
-          $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
+          $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
         }
         return 0;
       }
@@ -208,7 +249,7 @@ sub _eq_sql {
   else {
 
     # unroll parenthesis if possible/allowed
-    unless ( $parenthesis_significant ) {
+    unless ($parenthesis_significant) {
       $sqlat->_parenthesis_unroll($_) for $left, $right;
     }
 
@@ -217,7 +258,7 @@ sub _eq_sql {
       $sqlat->_strip_asc_from_order_by($_) for $left, $right;
     }
 
-    if ( $left->[0] ne $right->[0] ) {
+    if ($left->[0] ne $right->[0]) {
       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
         $sqlat->unparse($left),
         $sqlat->unparse($right)
@@ -237,7 +278,7 @@ sub _eq_sql {
     # if operators are identical, compare operands
     else {
       my $eq = _eq_sql($left->[1], $right->[1]);
-      $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
+      $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
       return $eq;
     }
   }