Add list support, and various mini-fixes
[scpubgit/Q-Branch.git] / lib / SQL / Abstract / Test.pm
1 package SQL::Abstract::Test; # see doc at end of file
2
3 use strict;
4 use warnings;
5 use base qw/Test::Builder::Module Exporter/;
6 use Data::Dumper;
7 use Test::Builder;
8 use SQL::Abstract::Tree;
9
10 our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
11                     &eq_sql_bind &eq_sql &eq_bind
12                     $case_sensitive $sql_differ/;
13
14 my $sqlat = SQL::Abstract::Tree->new;
15
16 our $case_sensitive = 0;
17 our $parenthesis_significant = 0;
18 our $sql_differ; # keeps track of differing portion between SQLs
19 our $tb = __PACKAGE__->builder;
20
21 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
22 my @unrollable_ops = (
23   'ON',
24   'WHERE',
25   'GROUP \s+ BY',
26   'HAVING',
27   'ORDER \s+ BY',
28 );
29 my $unrollable_ops_re = join ' | ', @unrollable_ops;
30 $unrollable_ops_re = qr/$unrollable_ops_re/xi;
31
32 sub is_same_sql_bind {
33   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
34
35   # compare
36   my $same_sql  = eq_sql($sql1, $sql2);
37   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
38
39   # call Test::Builder::ok
40   my $ret = $tb->ok($same_sql && $same_bind, $msg);
41
42   # add debugging info
43   if (!$same_sql) {
44     _sql_differ_diag($sql1, $sql2);
45   }
46   if (!$same_bind) {
47     _bind_differ_diag($bind_ref1, $bind_ref2);
48   }
49
50   # pass ok() result further
51   return $ret;
52 }
53
54 sub 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
61   my $ret = $tb->ok($same_sql, $msg);
62
63   # add debugging info
64   if (!$same_sql) {
65     _sql_differ_diag($sql1, $sql2);
66   }
67
68   # pass ok() result further
69   return $ret;
70 }
71
72 sub 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
79   my $ret = $tb->ok($same_bind, $msg);
80
81   # add debugging info
82   if (!$same_bind) {
83     _bind_differ_diag($bind_ref1, $bind_ref2);
84   }
85
86   # pass ok() result further
87   return $ret;
88 }
89
90 sub _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
100 sub _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
109 sub 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
116 sub eq_bind {
117   my ($bind_ref1, $bind_ref2) = @_;
118
119   local $Data::Dumper::Useqq = 1;
120   local $Data::Dumper::Sortkeys = 1;
121
122   return Dumper($bind_ref1) eq Dumper($bind_ref2);
123 }
124
125 sub eq_sql {
126   my ($sql1, $sql2) = @_;
127
128   # parse
129   my $tree1 = $sqlat->parse($sql1);
130   my $tree2 = $sqlat->parse($sql2);
131
132   return 1 if _eq_sql($tree1, $tree2);
133 }
134
135 sub _eq_sql {
136   my ($left, $right) = @_;
137
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) {
144     return 1;
145   }
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   }
155   # one is a list, the other is an op with a list
156   elsif (ref $left->[0] xor ref $right->[0]) {
157     $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
158     return 0;
159   }
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
170     # unroll parenthesis if possible/allowed
171     _parenthesis_unroll ($_) for ($left, $right);
172
173     # if operators are different
174     if ( $left->[0] ne $right->[0] ) {
175       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
176         $sqlat->unparse($left),
177         $sqlat->unparse($right);
178       return 0;
179     }
180     # elsif operators are identical, compare operands
181     else {
182       if ($left->[0] eq 'LITERAL' ) { # unary
183         (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
184         (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
185         my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
186         $sql_differ = "[$l] != [$r]\n" if not $eq;
187         return $eq;
188       }
189       else {
190         my $eq = _eq_sql($left->[1], $right->[1]);
191         $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
192         return $eq;
193       }
194     }
195   }
196 }
197
198 sub _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]}) {
210       # the current node in this loop is *always* a PAREN
211       if (not ref $child or not $child->[0] eq 'PAREN') {
212         push @children, $child;
213         next;
214       }
215
216       # unroll nested parenthesis
217       while ( @{$child->[1]} && $child->[1][0][0] eq 'PAREN') {
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       }
231
232       # if the parent operator explcitly allows it nuke the parenthesis
233       elsif ( $ast->[0] =~ $unrollable_ops_re ) {
234         push @children, $child->[1][0];
235         $changes++;
236       }
237
238       # only *ONE* LITERAL element
239       elsif (
240         @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
241       ) {
242         push @children, $child->[1][0];
243         $changes++;
244       }
245
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)
252       elsif (
253         @{$child->[1]} == 1
254           and
255         $child->[1][0][0] =~ SQL::Abstract::Tree::_binary_op_re()
256           and
257         $child->[1][0][0] ne 'BETWEEN'
258           and
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         )
266       ) {
267         push @children, $child->[1][0];
268         $changes++;
269       }
270
271       # a function binds tighter than a mathop - see if our ancestor is a
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 ? )
276       elsif (
277         @{$child->[1]} == 1
278           and
279         @{$child->[1][0][1]} == 1
280           and
281         $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
282           and
283         $child->[1][0][0] !~ SQL::Abstract::Tree::_math_op_re
284           and
285         (
286           $child->[1][0][1][0][0] eq 'PAREN'
287             or 
288           $child->[1][0][1][0][0] eq 'LITERAL'
289         )
290       ) {
291         push @children, $child->[1][0];
292         $changes++;
293       }
294
295
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 }
307
308 sub parse { $sqlat->parse(@_) }
309 1;
310
311
312 __END__
313
314 =head1 NAME
315
316 SQL::Abstract::Test - Helper function for testing SQL::Abstract
317
318 =head1 SYNOPSIS
319
320   use SQL::Abstract;
321   use Test::More;
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   /];
326
327   my ($sql, @bind) = SQL::Abstract->new->select(%args);
328
329   is_same_sql_bind($given_sql,    \@given_bind,
330                    $expected_sql, \@expected_bind, $test_msg);
331
332   is_same_sql($given_sql, $expected_sql, $test_msg);
333   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
334
335   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
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
341 =head1 DESCRIPTION
342
343 This module is only intended for authors of tests on
344 L<SQL::Abstract|SQL::Abstract> and related modules;
345 it exports functions for comparing two SQL statements
346 and their bound values.
347
348 The SQL comparison is performed on I<abstract syntax>,
349 ignoring differences in spaces or in levels of parentheses.
350 Therefore the tests will pass as long as the semantics
351 is preserved, even if the surface syntax has changed.
352
353 B<Disclaimer> : the semantic equivalence handling is pretty limited.
354 A lot of effort goes into distinguishing significant from
355 non-significant parenthesis, including AND/OR operator associativity.
356 Currently this module does not support commutativity and more
357 intelligent transformations like Morgan laws, etc.
358
359 For a good overview of what this test framework is capable of refer
360 to C<t/10test.t>
361
362 =head1 FUNCTIONS
363
364 =head2 is_same_sql_bind
365
366   is_same_sql_bind($given_sql,    \@given_bind,
367                    $expected_sql, \@expected_bind, $test_msg);
368
369 Compares given and expected pairs of C<($sql, \@bind)>, and calls
370 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
371 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
372 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
373 L</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
379 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
380 the result, with C<$test_msg> as message. If the test fails, a detailed
381 diagnostic is printed. For clients which use L<Test::More>, this is the one of
382 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
383 that needs to be imported.
384
385 =head2 is_same_bind
386
387   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
388
389 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
390 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
391 is printed. For clients which use L<Test::More>, this is the one of the three
392 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
393 to be imported.
394
395 =head2 eq_sql_bind
396
397   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
398                             $expected_sql, \@expected_bind);
399
400 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
401 L</is_same_sql_bind>, but it just returns a boolean value and does not print
402 diagnostics or talk to L<Test::Builder>.
403
404 =head2 eq_sql
405
406   my $is_same = eq_sql($given_sql, $expected_sql);
407
408 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
409 but it just returns a boolean value and does not print diagnostics or talk to
410 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
411 will contain the SQL portion where a difference was encountered; this is useful
412 for printing diagnostics.
413
414 =head2 eq_bind
415
416   my $is_same = eq_sql(\@given_bind, \@expected_bind);
417
418 Compares two lists of bind values, taking into account the fact that some of
419 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
420 L</is_same_bind>, but it just returns a boolean value and does not print
421 diagnostics or talk to L<Test::Builder>.
422
423 =head1 GLOBAL VARIABLES
424
425 =head2 $case_sensitive
426
427 If true, SQL comparisons will be case-sensitive. Default is false;
428
429 =head2 $parenthesis_significant
430
431 If true, SQL comparison will preserve and report difference in nested
432 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
433
434 =head2 $sql_differ
435
436 When L</eq_sql> returns false, the global variable
437 C<$sql_differ> contains the SQL portion
438 where a difference was encountered.
439
440
441 =head1 SEE ALSO
442
443 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
444
445 =head1 AUTHORS
446
447 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
448
449 Norbert Buchmuller <norbi@nix.hu>
450
451 Peter Rabbitson <ribasushi@cpan.org>
452
453 =head1 COPYRIGHT AND LICENSE
454
455 Copyright 2008 by Laurent Dami.
456
457 This library is free software; you can redistribute it and/or modify
458 it under the same terms as Perl itself.