t/TestSqlAbstract.pm

   1 package TestSqlAbstract;\r
   2 \r
   3 # compares two SQL expressions on their abstract syntax,\r
   4 # ignoring differences in levels of parentheses.\r
   5 \r
   6 use strict;\r
   7 use warnings;\r
   8 use Test::More;\r
   9 use base 'Exporter';\r
  10 use Data::Dumper;\r
  11 \r
  12 our @EXPORT = qw/is_same_sql_bind/;\r
  13 \r
  14 \r
  15 my $last_differ;\r
  16 \r
  17 sub is_same_sql_bind {\r
  18   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;\r
  19 \r
  20   my $tree1     = parse($sql1);\r
  21   my $tree2     = parse($sql2);\r
  22   my $same_sql  = eq_tree($tree1, $tree2);\r
  23   my $same_bind = stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);\r
  24   ok($same_sql && $same_bind, $msg);\r
  25   if (!$same_sql) {\r
  26     diag "SQL expressions differ\n"\r
  27         ."     got: $sql1\n"\r
  28         ."expected: $sql2\n"\r
  29         ."differing in :\n$last_differ\n";\r
  30         ;\r
  31   }\r
  32   if (!$same_bind) {\r
  33     diag "BIND values differ\n"\r
  34         ."     got: " . Dumper($bind_ref1)\r
  35         ."expected: " . Dumper($bind_ref2)\r
  36         ;\r
  37   }\r
  38 }\r
  39 \r
  40 sub stringify_bind {\r
  41   my $bind_ref = shift || [];\r
  42   return join "///", map {ref $_ ? join('=>', @$_) : ($_ || '')} \r
  43                          @$bind_ref;\r
  44 }\r
  45 \r
  46 \r
  47 \r
  48 sub eq_tree {\r
  49   my ($left, $right) = @_;\r
  50 \r
  51   # ignore top-level parentheses \r
  52   while ($left->[0]  eq 'PAREN') {$left  = $left->[1] }\r
  53   while ($right->[0] eq 'PAREN') {$right = $right->[1]}\r
  54 \r
  55   if ($left->[0] ne $right->[0]) { # if operators are different\r
  56     $last_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",\r
  57       unparse($left),\r
  58       unparse($right);\r
  59     return 0;\r
  60   }\r
  61   else { # else compare operands\r
  62     if ($left->[0] eq 'EXPR' ) {\r
  63       if ($left->[1] ne $right->[1]) {\r
  64         $last_differ = "[$left->[1]] != [$right->[1]]\n";\r
  65         return 0;\r
  66       }\r
  67       else {\r
  68         return 1;\r
  69       }\r
  70     }\r
  71     else {\r
  72       my $eq_left  = eq_tree($left->[1][0], $right->[1][0]);\r
  73       my $eq_right = eq_tree($left->[1][1], $right->[1][1]);\r
  74       return $eq_left && $eq_right;\r
  75     }\r
  76   }\r
  77 }\r
  78 \r
  79 \r
  80 my @tokens;\r
  81 \r
  82 sub parse {\r
  83   my $s = shift;\r
  84 \r
  85   # tokenize string\r
  86   @tokens = grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s;\r
  87 \r
  88   my $tree = _recurse_parse();\r
  89   return $tree;\r
  90 }\r
  91 \r
  92 sub _recurse_parse {\r
  93 \r
  94   my $left;\r
  95   while (1) {\r
  96 \r
  97     my $lookahead = $tokens[0];\r
  98     return $left if !defined($lookahead) || $lookahead eq ')';\r
  99 \r
 100     my $token = shift @tokens;\r
 101 \r
 102     if ($token eq '(') {\r
 103       my $right = _recurse_parse();\r
 104       $token = shift @tokens \r
 105         or die "missing ')'";\r
 106       $token eq ')' \r
 107         or die "unexpected token : $token";\r
 108       $left = $left ? [CONCAT => [$left, [PAREN => $right]]]\r
 109                     : [PAREN  => $right];\r
 110     }\r
 111     elsif ($token eq 'AND' || $token eq 'OR')  {\r
 112       my $right = _recurse_parse();\r
 113       $left = [$token => [$left, $right]];\r
 114     }\r
 115     else {\r
 116       $left = $left ? [CONCAT => [$left, [EXPR => $token]]]\r
 117                     : [EXPR   => $token];\r
 118     }\r
 119   }\r
 120 }\r
 121 \r
 122 \r
 123 \r
 124 sub unparse {\r
 125   my $tree = shift;\r
 126   my $dispatch = {\r
 127     EXPR   => sub {$tree->[1]                                   },\r
 128     PAREN  => sub {"(" . unparse($tree->[1]) . ")"              },\r
 129     CONCAT => sub {join " ",     map {unparse($_)} @{$tree->[1]}},\r
 130     AND    => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},\r
 131     OR     => sub {join " OR ",  map {unparse($_)} @{$tree->[1]}},\r
 132    };\r
 133   $dispatch->{$tree->[0]}->();\r
 134 }\r
 135 \r
 136 \r
 137 1;\r