moved internal test module into published SQL/Abstract/Test, so that clients of SQLA...

diff --git a/MANIFEST b/MANIFEST
index d44f80c..5ca4d1a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,6 +1,7 @@
 Changes\r
 INSTALL\r
 lib/SQL/Abstract.pm\r
+lib/SQL/Abstract/Test.pm\r
 Makefile.PL\r
 MANIFEST                       This list of files\r
 t/00new.t\r
@@ -10,4 +11,4 @@ t/03values.t
 t/06order_by.t\r
 t/07subqueries.t\r
 t/08special_ops.t\r
-t/TestSqlAbstract.pm\r
+\r

diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm
new file mode 100644 (file)
index 0000000..e4b4d22
--- /dev/null
+++ b/lib/SQL/Abstract/Test.pm
@@ -0,0 +1,240 @@
+package SQL::Abstract::Test; # see doc at end of file\r
+\r
+use strict;\r
+use warnings;\r
+use Test::More;\r
+use base 'Exporter';\r
+use Data::Dumper;\r
+use Carp;\r
+\r
+our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind \r
+                    $case_sensitive $sql_differ/;\r
+\r
+our $case_sensitive = 0;\r
+our $sql_differ; # keeps track of differing portion between SQLs\r
+\r
+sub is_same_sql_bind {\r
+  my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;\r
+\r
+  # compare\r
+  my $tree1     = parse($sql1);\r
+  my $tree2     = parse($sql2);\r
+  my $same_sql  = eq_sql($tree1, $tree2);\r
+  my $same_bind = eq_bind($bind_ref1, $bind_ref2);\r
+\r
+  # call Test::More::ok\r
+  ok($same_sql && $same_bind, $msg);\r
+\r
+  # add debugging info\r
+  if (!$same_sql) {\r
+    diag "SQL expressions differ\n"\r
+        ."     got: $sql1\n"\r
+        ."expected: $sql2\n"\r
+        ."differing in :\n$sql_differ\n";\r
+        ;\r
+  }\r
+  if (!$same_bind) {\r
+    diag "BIND values differ\n"\r
+        ."     got: " . Dumper($bind_ref1)\r
+        ."expected: " . Dumper($bind_ref2)\r
+        ;\r
+  }\r
+}\r
+\r
+\r
+sub eq_bind {\r
+  my ($bind_ref1, $bind_ref2) = @_;\r
+  return stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);\r
+}\r
+\r
+sub stringify_bind {\r
+  my $bind_ref = shift || [];\r
+\r
+  # some bind values can be arrayrefs (see L<SQL::Abstract/bindtype>),\r
+  # so stringify them.\r
+  my @strings = map {ref $_ ? join('=>', @$_) : ($_ || '')} @$bind_ref;\r
+\r
+  # join all values into a single string\r
+  return join "///", @strings;\r
+}\r
+\r
+sub eq_sql {\r
+  my ($left, $right) = @_;\r
+\r
+  # ignore top-level parentheses \r
+  while ($left->[0]  eq 'PAREN') {$left  = $left->[1] }\r
+  while ($right->[0] eq 'PAREN') {$right = $right->[1]}\r
+\r
+  # if operators are different\r
+  if ($left->[0] ne $right->[0]) { \r
+    $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",\r
+      unparse($left),\r
+      unparse($right);\r
+    return 0;\r
+  }\r
+  # elsif operators are identical, compare operands\r
+  else { \r
+    if ($left->[0] eq 'EXPR' ) { # unary operator\r
+      (my $l = " $left->[1] " ) =~ s/\s+/ /g;\r
+      (my $r = " $right->[1] ") =~ s/\s+/ /g;\r
+      my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);\r
+      $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;\r
+      return $eq;\r
+    }\r
+    else { # binary operator\r
+      return eq_sql($left->[1][0], $right->[1][0])  # left operand\r
+          && eq_sql($left->[1][1], $right->[1][1]); # right operand\r
+    }\r
+  }\r
+}\r
+\r
+\r
+sub parse {\r
+  my $s = shift;\r
+\r
+  # tokenize string\r
+  my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];\r
+\r
+  my $tree = _recurse_parse($tokens);\r
+  return $tree;\r
+}\r
+\r
+sub _recurse_parse {\r
+  my $tokens = shift;\r
+\r
+  my $left;\r
+  while (1) { # left-associative parsing\r
+\r
+    my $lookahead = $tokens->[0];\r
+    return $left if !defined($lookahead) || $lookahead eq ')';\r
+\r
+    my $token = shift @$tokens;\r
+\r
+    # nested expression in ()\r
+    if ($token eq '(') {\r
+      my $right = _recurse_parse($tokens);\r
+      $token = shift @$tokens   or croak "missing ')'";\r
+      $token eq ')'             or croak "unexpected token : $token";\r
+      $left = $left ? [CONCAT => [$left, [PAREN => $right]]]\r
+                    : [PAREN  => $right];\r
+    }\r
+    # AND/OR\r
+    elsif ($token eq 'AND' || $token eq 'OR')  {\r
+      my $right = _recurse_parse($tokens);\r
+      $left = [$token => [$left, $right]];\r
+    }\r
+    # leaf expression\r
+    else {\r
+      $left = $left ? [CONCAT => [$left, [EXPR => $token]]]\r
+                    : [EXPR   => $token];\r
+    }\r
+  }\r
+}\r
+\r
+\r
+\r
+sub unparse {\r
+  my $tree = shift;\r
+  my $dispatch = {\r
+    EXPR   => sub {$tree->[1]                                   },\r
+    PAREN  => sub {"(" . unparse($tree->[1]) . ")"              },\r
+    CONCAT => sub {join " ",     map {unparse($_)} @{$tree->[1]}},\r
+    AND    => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},\r
+    OR     => sub {join " OR ",  map {unparse($_)} @{$tree->[1]}},\r
+   };\r
+  $dispatch->{$tree->[0]}->();\r
+}\r
+\r
+\r
+1;\r
+\r
+\r
+__END__\r
+\r
+=head1 NAME\r
+\r
+SQL::Abstract::Test - Helper function for testing SQL::Abstract\r
+\r
+=head1 SYNOPSIS\r
+\r
+  use SQL::Abstract;\r
+  use Test::More;\r
+  use SQL::Abstract::Test qw/is_same_sql_bind/;\r
+  \r
+  my ($sql, @bind) = SQL::Abstract->new->select(%args);\r
+  is_same_sql_bind($given_sql,    \@given_bind, \r
+                   $expected_sql, \@expected_bind, $test_msg);\r
+\r
+=head1 DESCRIPTION\r
+\r
+This module is only intended for authors of tests on\r
+L<SQL::Abstract|SQL::Abstract> and related modules;\r
+it exports functions for comparing two SQL statements\r
+and their bound values.\r
+\r
+The SQL comparison is performed on I<abstract syntax>,\r
+ignoring differences in spaces or in levels of parentheses.\r
+Therefore the tests will pass as long as the semantics\r
+is preserved, even if the surface syntax has changed.\r
+\r
+B<Disclaimer> : this is only a half-cooked semantic equivalence;\r
+parsing is simple-minded, and comparison of SQL abstract syntax trees\r
+ignores commutativity or associativity of AND/OR operators, Morgan\r
+laws, etc.\r
+\r
+=head1 FUNCTIONS\r
+\r
+=head2 is_same_sql_bind\r
+\r
+  is_same_sql_bind($given_sql,    \@given_bind, \r
+                   $expected_sql, \@expected_bind, $test_msg);\r
+\r
+Compares given and expected pairs of C<($sql, \@bind)>, and calls\r
+L<Test::More/ok> on the result, with C<$test_msg> as message. If the\r
+test fails, a detailed diagnostic is printed. For clients which use\r
+L<Test::More|Test::More>, this is the only function that needs to be\r
+imported.\r
+\r
+=head2 eq_sql\r
+\r
+  my $is_same = eq_sql($given_sql, $expected_sql);\r
+\r
+Compares the abstract syntax of two SQL statements.  If the result is\r
+false, global variable L</sql_differ> will contain the SQL portion\r
+where a difference was encountered; this is useful for printing diagnostics.\r
+\r
+=head2 eq_bind\r
+\r
+  my $is_same = eq_sql(\@given_bind, \@expected_bind);\r
+\r
+Compares two lists of bind values, taking into account\r
+the fact that some of the values may be\r
+arrayrefs (see L<SQL::Abstract/bindtype>).\r
+\r
+=head1 GLOBAL VARIABLES\r
+\r
+=head2 case_sensitive\r
+\r
+If true, SQL comparisons will be case-sensitive. Default is false;\r
+\r
+=head2 sql_differ\r
+\r
+When L</eq_sql> returns false, the global variable\r
+C<$sql_differ> contains the SQL portion\r
+where a difference was encountered.\r
+\r
+\r
+=head1 SEE ALSO\r
+\r
+L<SQL::Abstract>, L<Test::More>.\r
+\r
+=head1 AUTHOR\r
+\r
+Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>\r
+\r
+=head1 COPYRIGHT AND LICENSE\r
+\r
+Copyright 2008 by Laurent Dami.\r
+\r
+This library is free software; you can redistribute it and/or modify\r
+it under the same terms as Perl itself. \r

diff --git a/t/00new.t b/t/00new.t
index 989a0b2..ee83650 100644 (file)
--- a/t/00new.t
+++ b/t/00new.t
@@ -4,10 +4,7 @@ use strict;
 use warnings;
 use Test::More;
 
-use FindBin;
-use lib "$FindBin::Bin";
-use TestSqlAbstract;
-
+use SQL::Abstract::Test qw/is_same_sql_bind/;
 
 plan tests => 15;
 

diff --git a/t/01generate.t b/t/01generate.t
index 9fbae62..2362e6c 100644 (file)
--- a/t/01generate.t
+++ b/t/01generate.t
@@ -4,10 +4,7 @@ use strict;
 use warnings;
 use Test::More;
 
-use FindBin;
-use lib "$FindBin::Bin";
-use TestSqlAbstract;
-
+use SQL::Abstract::Test qw/is_same_sql_bind/;
 plan tests => 64;
 
 use SQL::Abstract;

diff --git a/t/02where.t b/t/02where.t
index b279651..3e9e649 100644 (file)
--- a/t/02where.t
+++ b/t/02where.t
@@ -5,10 +5,7 @@ use warnings;
 use Test::More;
 use Test::Exception;
 
-use FindBin;
-use lib "$FindBin::Bin";
-use TestSqlAbstract;
-
+use SQL::Abstract::Test qw/is_same_sql_bind/;
 plan tests => 15;
 
 use SQL::Abstract;

diff --git a/t/03values.t b/t/03values.t
index f5e4ffc..9cde7cd 100644 (file)
--- a/t/03values.t
+++ b/t/03values.t
@@ -4,10 +4,7 @@ use strict;
 use warnings;
 use Test::More;
 
-use FindBin;
-use lib "$FindBin::Bin";
-use TestSqlAbstract;
-
+use SQL::Abstract::Test qw/is_same_sql_bind/;
 plan tests => 5;
 
 use SQL::Abstract;

diff --git a/t/06order_by.t b/t/06order_by.t
index a8fc1c7..08477ec 100644 (file)
--- a/t/06order_by.t
+++ b/t/06order_by.t
@@ -6,10 +6,7 @@ use Test::More;
 
 use SQL::Abstract;
 
-use FindBin;
-use lib "$FindBin::Bin";
-use TestSqlAbstract;
-
+use SQL::Abstract::Test qw/is_same_sql_bind/;
 my @cases = 
   (
    {

diff --git a/t/07subqueries.t b/t/07subqueries.t
index b3840d5..c86314f 100644 (file)
--- a/t/07subqueries.t
+++ b/t/07subqueries.t
@@ -4,10 +4,7 @@ use strict;
 use warnings;\r
 use Test::More;\r
 \r
-use FindBin;\r
-use lib "$FindBin::Bin";\r
-use TestSqlAbstract;\r
-\r
+use SQL::Abstract::Test qw/is_same_sql_bind/;\r
 plan tests => 5;\r
 \r
 use SQL::Abstract;\r

diff --git a/t/08special_ops.t b/t/08special_ops.t
index 5bc5996..bbccd14 100644 (file)
--- a/t/08special_ops.t
+++ b/t/08special_ops.t
@@ -4,10 +4,7 @@ use strict;
 use warnings;\r
 use Test::More;\r
 \r
-use FindBin;\r
-use lib "$FindBin::Bin";\r
-use TestSqlAbstract;\r
-\r
+use SQL::Abstract::Test qw/is_same_sql_bind/;\r
 plan tests => 2;\r
 \r
 use SQL::Abstract;\r

diff --git a/t/TestSqlAbstract.pm b/t/TestSqlAbstract.pm
deleted file mode 100644 (file)
index ba8a100..0000000
--- a/t/TestSqlAbstract.pm
+++ /dev/null
@@ -1,137 +0,0 @@
-package TestSqlAbstract;\r
-\r
-# compares two SQL expressions on their abstract syntax,\r
-# ignoring differences in levels of parentheses.\r
-\r
-use strict;\r
-use warnings;\r
-use Test::More;\r
-use base 'Exporter';\r
-use Data::Dumper;\r
-\r
-our @EXPORT = qw/is_same_sql_bind/;\r
-\r
-\r
-my $last_differ;\r
-\r
-sub is_same_sql_bind {\r
-  my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;\r
-\r
-  my $tree1     = parse($sql1);\r
-  my $tree2     = parse($sql2);\r
-  my $same_sql  = eq_tree($tree1, $tree2);\r
-  my $same_bind = stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);\r
-  ok($same_sql && $same_bind, $msg);\r
-  if (!$same_sql) {\r
-    diag "SQL expressions differ\n"\r
-        ."     got: $sql1\n"\r
-        ."expected: $sql2\n"\r
-        ."differing in :\n$last_differ\n";\r
-        ;\r
-  }\r
-  if (!$same_bind) {\r
-    diag "BIND values differ\n"\r
-        ."     got: " . Dumper($bind_ref1)\r
-        ."expected: " . Dumper($bind_ref2)\r
-        ;\r
-  }\r
-}\r
-\r
-sub stringify_bind {\r
-  my $bind_ref = shift || [];\r
-  return join "///", map {ref $_ ? join('=>', @$_) : ($_ || '')} \r
-                         @$bind_ref;\r
-}\r
-\r
-\r
-\r
-sub eq_tree {\r
-  my ($left, $right) = @_;\r
-\r
-  # ignore top-level parentheses \r
-  while ($left->[0]  eq 'PAREN') {$left  = $left->[1] }\r
-  while ($right->[0] eq 'PAREN') {$right = $right->[1]}\r
-\r
-  if ($left->[0] ne $right->[0]) { # if operators are different\r
-    $last_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",\r
-      unparse($left),\r
-      unparse($right);\r
-    return 0;\r
-  }\r
-  else { # else compare operands\r
-    if ($left->[0] eq 'EXPR' ) {\r
-      if ($left->[1] ne $right->[1]) {\r
-        $last_differ = "[$left->[1]] != [$right->[1]]\n";\r
-        return 0;\r
-      }\r
-      else {\r
-        return 1;\r
-      }\r
-    }\r
-    else {\r
-      my $eq_left  = eq_tree($left->[1][0], $right->[1][0]);\r
-      my $eq_right = eq_tree($left->[1][1], $right->[1][1]);\r
-      return $eq_left && $eq_right;\r
-    }\r
-  }\r
-}\r
-\r
-\r
-my @tokens;\r
-\r
-sub parse {\r
-  my $s = shift;\r
-\r
-  # tokenize string\r
-  @tokens = grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s;\r
-\r
-  my $tree = _recurse_parse();\r
-  return $tree;\r
-}\r
-\r
-sub _recurse_parse {\r
-\r
-  my $left;\r
-  while (1) {\r
-\r
-    my $lookahead = $tokens[0];\r
-    return $left if !defined($lookahead) || $lookahead eq ')';\r
-\r
-    my $token = shift @tokens;\r
-\r
-    if ($token eq '(') {\r
-      my $right = _recurse_parse();\r
-      $token = shift @tokens \r
-        or die "missing ')'";\r
-      $token eq ')' \r
-        or die "unexpected token : $token";\r
-      $left = $left ? [CONCAT => [$left, [PAREN => $right]]]\r
-                    : [PAREN  => $right];\r
-    }\r
-    elsif ($token eq 'AND' || $token eq 'OR')  {\r
-      my $right = _recurse_parse();\r
-      $left = [$token => [$left, $right]];\r
-    }\r
-    else {\r
-      $left = $left ? [CONCAT => [$left, [EXPR => $token]]]\r
-                    : [EXPR   => $token];\r
-    }\r
-  }\r
-}\r
-\r
-\r
-\r
-sub unparse {\r
-  my $tree = shift;\r
-  my $dispatch = {\r
-    EXPR   => sub {$tree->[1]                                   },\r
-    PAREN  => sub {"(" . unparse($tree->[1]) . ")"              },\r
-    CONCAT => sub {join " ",     map {unparse($_)} @{$tree->[1]}},\r
-    AND    => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},\r
-    OR     => sub {join " OR ",  map {unparse($_)} @{$tree->[1]}},\r
-   };\r
-  $dispatch->{$tree->[0]}->();\r
-}\r
-\r
-\r
-1;\r