Add list support, and various mini-fixes
[scpubgit/Q-Branch.git] / lib / SQL / Abstract / Test.pm
CommitLineData
fffe6900 1package SQL::Abstract::Test; # see doc at end of file
2
3use strict;
4use warnings;
5aad8cf3 5use base qw/Test::Builder::Module Exporter/;
fffe6900 6use Data::Dumper;
4abea32b 7use Test::Builder;
01dd4e4f 8use SQL::Abstract::Tree;
fffe6900 9
e7827ba2 10our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
01dd4e4f 11 &eq_sql_bind &eq_sql &eq_bind
fffe6900 12 $case_sensitive $sql_differ/;
13
a24cc3a0 14my $sqlat = SQL::Abstract::Tree->new;
15
fffe6900 16our $case_sensitive = 0;
e40f5df9 17our $parenthesis_significant = 0;
fffe6900 18our $sql_differ; # keeps track of differing portion between SQLs
5aad8cf3 19our $tb = __PACKAGE__->builder;
fffe6900 20
35149895 21# All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
01b64cb7 22my @unrollable_ops = (
1b17d1b0 23 'ON',
24 'WHERE',
25 'GROUP \s+ BY',
26 'HAVING',
27 'ORDER \s+ BY',
28);
6f01d627 29my $unrollable_ops_re = join ' | ', @unrollable_ops;
b7b0f832 30$unrollable_ops_re = qr/$unrollable_ops_re/xi;
1b17d1b0 31
fffe6900 32sub is_same_sql_bind {
33 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
34
35 # compare
25823711 36 my $same_sql = eq_sql($sql1, $sql2);
fffe6900 37 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
38
a6daa642 39 # call Test::Builder::ok
1a828f61 40 my $ret = $tb->ok($same_sql && $same_bind, $msg);
fffe6900 41
42 # add debugging info
43 if (!$same_sql) {
e7827ba2 44 _sql_differ_diag($sql1, $sql2);
fffe6900 45 }
46 if (!$same_bind) {
e7827ba2 47 _bind_differ_diag($bind_ref1, $bind_ref2);
fffe6900 48 }
1a828f61 49
50 # pass ok() result further
51 return $ret;
fffe6900 52}
53
e7827ba2 54sub is_same_sql {
55 my ($sql1, $sql2, $msg) = @_;
56
57 # compare
58 my $same_sql = eq_sql($sql1, $sql2);
59
60 # call Test::Builder::ok
1a828f61 61 my $ret = $tb->ok($same_sql, $msg);
e7827ba2 62
63 # add debugging info
64 if (!$same_sql) {
65 _sql_differ_diag($sql1, $sql2);
66 }
1a828f61 67
68 # pass ok() result further
69 return $ret;
e7827ba2 70}
71
72sub is_same_bind {
73 my ($bind_ref1, $bind_ref2, $msg) = @_;
74
75 # compare
76 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
77
78 # call Test::Builder::ok
1a828f61 79 my $ret = $tb->ok($same_bind, $msg);
e7827ba2 80
81 # add debugging info
82 if (!$same_bind) {
83 _bind_differ_diag($bind_ref1, $bind_ref2);
84 }
1a828f61 85
86 # pass ok() result further
87 return $ret;
e7827ba2 88}
89
90sub _sql_differ_diag {
91 my ($sql1, $sql2) = @_;
92
93 $tb->diag("SQL expressions differ\n"
94 ." got: $sql1\n"
95 ."expected: $sql2\n"
96 ."differing in :\n$sql_differ\n"
97 );
98}
99
100sub _bind_differ_diag {
101 my ($bind_ref1, $bind_ref2) = @_;
102
103 $tb->diag("BIND values differ\n"
104 ." got: " . Dumper($bind_ref1)
105 ."expected: " . Dumper($bind_ref2)
106 );
107}
108
109sub eq_sql_bind {
110 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
111
112 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
113}
114
115
fffe6900 116sub eq_bind {
117 my ($bind_ref1, $bind_ref2) = @_;
fffe6900 118
fdfbbc65 119 local $Data::Dumper::Useqq = 1;
120 local $Data::Dumper::Sortkeys = 1;
121
122 return Dumper($bind_ref1) eq Dumper($bind_ref2);
fffe6900 123}
124
125sub eq_sql {
25823711 126 my ($sql1, $sql2) = @_;
127
128 # parse
a24cc3a0 129 my $tree1 = $sqlat->parse($sql1);
130 my $tree2 = $sqlat->parse($sql2);
25823711 131
1b17d1b0 132 return 1 if _eq_sql($tree1, $tree2);
25823711 133}
134
135sub _eq_sql {
fffe6900 136 my ($left, $right) = @_;
137
939db550 138 # one is defined the other not
139 if ( (defined $left) xor (defined $right) ) {
140 return 0;
141 }
142 # one is undefined, then so is the other
143 elsif (not defined $left) {
d15c14cc 144 return 1;
145 }
0769ac0e 146 # different amount of elements
147 elsif (@$left != @$right) {
148 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
149 return 0;
150 }
151 # one is empty - so is the other
152 elsif (@$left == 0) {
153 return 1;
154 }
1b17d1b0 155 # one is a list, the other is an op with a list
156 elsif (ref $left->[0] xor ref $right->[0]) {
a24cc3a0 157 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
fffe6900 158 return 0;
159 }
1b17d1b0 160 # one is a list, so is the other
161 elsif (ref $left->[0]) {
162 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
163 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
164 }
165 return 1;
166 }
167 # both are an op-list combo
168 else {
169
e40f5df9 170 # unroll parenthesis if possible/allowed
171 _parenthesis_unroll ($_) for ($left, $right);
1b17d1b0 172
173 # if operators are different
b9a4fdae 174 if ( $left->[0] ne $right->[0] ) {
1b17d1b0 175 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
a24cc3a0 176 $sqlat->unparse($left),
177 $sqlat->unparse($right);
1b17d1b0 178 return 0;
179 }
180 # elsif operators are identical, compare operands
01dd4e4f 181 else {
b9a4fdae 182 if ($left->[0] eq 'LITERAL' ) { # unary
01b64cb7 183 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
184 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
1b17d1b0 185 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
01b64cb7 186 $sql_differ = "[$l] != [$r]\n" if not $eq;
1b17d1b0 187 return $eq;
188 }
189 else {
190 my $eq = _eq_sql($left->[1], $right->[1]);
a24cc3a0 191 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
1b17d1b0 192 return $eq;
193 }
fffe6900 194 }
195 }
196}
197
e40f5df9 198sub _parenthesis_unroll {
199 my $ast = shift;
200
201 return if $parenthesis_significant;
202 return unless (ref $ast and ref $ast->[1]);
203
204 my $changes;
205 do {
206 my @children;
207 $changes = 0;
208
209 for my $child (@{$ast->[1]}) {
0769ac0e 210 # the current node in this loop is *always* a PAREN
e40f5df9 211 if (not ref $child or not $child->[0] eq 'PAREN') {
212 push @children, $child;
213 next;
214 }
215
216 # unroll nested parenthesis
0769ac0e 217 while ( @{$child->[1]} && $child->[1][0][0] eq 'PAREN') {
e40f5df9 218 $child = $child->[1][0];
219 $changes++;
220 }
221
222 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
223 if (
224 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
225 and
226 $child->[1][0][0] eq $ast->[0]
227 ) {
228 push @children, @{$child->[1][0][1]};
229 $changes++;
230 }
fffe6900 231
e40f5df9 232 # if the parent operator explcitly allows it nuke the parenthesis
6f01d627 233 elsif ( $ast->[0] =~ $unrollable_ops_re ) {
e40f5df9 234 push @children, $child->[1][0];
235 $changes++;
236 }
237
0769ac0e 238 # only *ONE* LITERAL element
9e8dab3f 239 elsif (
b9a4fdae 240 @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
9e8dab3f 241 ) {
242 push @children, $child->[1][0];
243 $changes++;
244 }
245
0769ac0e 246 # only one element in the parenthesis which is a binary op
247 # and has exactly two grandchildren
248 # the only time when we can *not* unroll this is when both
249 # the parent and the child are mathops (in which case we'll
250 # break precedence) or when the child is BETWEEN (special
251 # case)
e40f5df9 252 elsif (
253 @{$child->[1]} == 1
254 and
0769ac0e 255 $child->[1][0][0] =~ SQL::Abstract::Tree::_binary_op_re()
e40f5df9 256 and
0769ac0e 257 $child->[1][0][0] ne 'BETWEEN'
e40f5df9 258 and
0769ac0e 259 @{$child->[1][0][1]} == 2
260 and
261 ! (
262 $child->[1][0][0] =~ SQL::Abstract::Tree::_math_op_re()
263 and
264 $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
265 )
e40f5df9 266 ) {
267 push @children, $child->[1][0];
268 $changes++;
269 }
270
0769ac0e 271 # a function binds tighter than a mathop - see if our ancestor is a
b3b79607 272 # mathop, and our content is:
273 # a single non-mathop child with a single PAREN grandchild which
274 # would indicate mathop ( nonmathop ( ... ) )
275 # or a single non-mathop with a single LITERAL ( nonmathop ? )
0769ac0e 276 elsif (
277 @{$child->[1]} == 1
278 and
279 @{$child->[1][0][1]} == 1
280 and
0769ac0e 281 $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
282 and
283 $child->[1][0][0] !~ SQL::Abstract::Tree::_math_op_re
b3b79607 284 and
285 (
286 $child->[1][0][1][0][0] eq 'PAREN'
287 or
288 $child->[1][0][1][0][0] eq 'LITERAL'
289 )
0769ac0e 290 ) {
291 push @children, $child->[1][0];
292 $changes++;
293 }
294
295
e40f5df9 296 # otherwise no more mucking for this pass
297 else {
298 push @children, $child;
299 }
300 }
301
302 $ast->[1] = \@children;
303
304 } while ($changes);
305
306}
fffe6900 307
7853a177 308sub parse { $sqlat->parse(@_) }
fffe6900 3091;
310
311
312__END__
313
314=head1 NAME
315
316SQL::Abstract::Test - Helper function for testing SQL::Abstract
317
318=head1 SYNOPSIS
319
320 use SQL::Abstract;
321 use Test::More;
e7827ba2 322 use SQL::Abstract::Test import => [qw/
323 is_same_sql_bind is_same_sql is_same_bind
324 eq_sql_bind eq_sql eq_bind
325 /];
ec9af79e 326
fffe6900 327 my ($sql, @bind) = SQL::Abstract->new->select(%args);
e7827ba2 328
01dd4e4f 329 is_same_sql_bind($given_sql, \@given_bind,
fffe6900 330 $expected_sql, \@expected_bind, $test_msg);
331
e7827ba2 332 is_same_sql($given_sql, $expected_sql, $test_msg);
333 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
334
01dd4e4f 335 my $is_same = eq_sql_bind($given_sql, \@given_bind,
e7827ba2 336 $expected_sql, \@expected_bind);
337
338 my $sql_same = eq_sql($given_sql, $expected_sql);
339 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
340
fffe6900 341=head1 DESCRIPTION
342
343This module is only intended for authors of tests on
344L<SQL::Abstract|SQL::Abstract> and related modules;
345it exports functions for comparing two SQL statements
346and their bound values.
347
348The SQL comparison is performed on I<abstract syntax>,
349ignoring differences in spaces or in levels of parentheses.
350Therefore the tests will pass as long as the semantics
351is preserved, even if the surface syntax has changed.
352
ec9af79e 353B<Disclaimer> : the semantic equivalence handling is pretty limited.
354A lot of effort goes into distinguishing significant from
355non-significant parenthesis, including AND/OR operator associativity.
356Currently this module does not support commutativity and more
357intelligent transformations like Morgan laws, etc.
358
01dd4e4f 359For a good overview of what this test framework is capable of refer
ec9af79e 360to C<t/10test.t>
fffe6900 361
362=head1 FUNCTIONS
363
364=head2 is_same_sql_bind
365
01dd4e4f 366 is_same_sql_bind($given_sql, \@given_bind,
fffe6900 367 $expected_sql, \@expected_bind, $test_msg);
368
369Compares given and expected pairs of C<($sql, \@bind)>, and calls
e7827ba2 370L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
371fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
372this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
373L</is_same_bind>) that needs to be imported.
374
375=head2 is_same_sql
376
377 is_same_sql($given_sql, $expected_sql, $test_msg);
378
379Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
380the result, with C<$test_msg> as message. If the test fails, a detailed
381diagnostic is printed. For clients which use L<Test::More>, this is the one of
382the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
383that needs to be imported.
384
385=head2 is_same_bind
386
387 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
388
389Compares given and expected bind values, and calls L<Test::Builder/ok> on the
390result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
391is printed. For clients which use L<Test::More>, this is the one of the three
392functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
393to be imported.
394
395=head2 eq_sql_bind
396
01dd4e4f 397 my $is_same = eq_sql_bind($given_sql, \@given_bind,
e7827ba2 398 $expected_sql, \@expected_bind);
399
400Compares given and expected pairs of C<($sql, \@bind)>. Similar to
401L</is_same_sql_bind>, but it just returns a boolean value and does not print
402diagnostics or talk to L<Test::Builder>.
fffe6900 403
404=head2 eq_sql
405
406 my $is_same = eq_sql($given_sql, $expected_sql);
407
e7827ba2 408Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
409but it just returns a boolean value and does not print diagnostics or talk to
410L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
411will contain the SQL portion where a difference was encountered; this is useful
412for printing diagnostics.
fffe6900 413
414=head2 eq_bind
415
416 my $is_same = eq_sql(\@given_bind, \@expected_bind);
417
e7827ba2 418Compares two lists of bind values, taking into account the fact that some of
419the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
420L</is_same_bind>, but it just returns a boolean value and does not print
421diagnostics or talk to L<Test::Builder>.
fffe6900 422
423=head1 GLOBAL VARIABLES
424
e7827ba2 425=head2 $case_sensitive
fffe6900 426
427If true, SQL comparisons will be case-sensitive. Default is false;
428
e40f5df9 429=head2 $parenthesis_significant
430
431If true, SQL comparison will preserve and report difference in nested
432parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
433
e7827ba2 434=head2 $sql_differ
fffe6900 435
436When L</eq_sql> returns false, the global variable
437C<$sql_differ> contains the SQL portion
438where a difference was encountered.
439
440
441=head1 SEE ALSO
442
a6daa642 443L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
fffe6900 444
25823711 445=head1 AUTHORS
fffe6900 446
447Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
448
25823711 449Norbert Buchmuller <norbi@nix.hu>
450
e96c510a 451Peter Rabbitson <ribasushi@cpan.org>
452
fffe6900 453=head1 COPYRIGHT AND LICENSE
454
455Copyright 2008 by Laurent Dami.
456
457This library is free software; you can redistribute it and/or modify
01dd4e4f 458it under the same terms as Perl itself.