more improvements / fixes in documentation

[scpubgit/Q-Branch.git] / t / TestSqlAbstract.pm

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