Commit | Line | Data |
96449e8e |
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 |