numify version

[dbsrgits/SQL-Abstract.git] / lib / SQL / Abstract / Test.pm

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