rename DBIC::Storage::PP and get ready to re-release
[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
30 sub is_same_sql_bind {
31   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
32
33   # compare
34   my $same_sql  = eq_sql($sql1, $sql2);
35   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
36
37   # call Test::Builder::ok
38   my $ret = $tb->ok($same_sql && $same_bind, $msg);
39
40   # add debugging info
41   if (!$same_sql) {
42     _sql_differ_diag($sql1, $sql2);
43   }
44   if (!$same_bind) {
45     _bind_differ_diag($bind_ref1, $bind_ref2);
46   }
47
48   # pass ok() result further
49   return $ret;
50 }
51
52 sub is_same_sql {
53   my ($sql1, $sql2, $msg) = @_;
54
55   # compare
56   my $same_sql  = eq_sql($sql1, $sql2);
57
58   # call Test::Builder::ok
59   my $ret = $tb->ok($same_sql, $msg);
60
61   # add debugging info
62   if (!$same_sql) {
63     _sql_differ_diag($sql1, $sql2);
64   }
65
66   # pass ok() result further
67   return $ret;
68 }
69
70 sub is_same_bind {
71   my ($bind_ref1, $bind_ref2, $msg) = @_;
72
73   # compare
74   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
75
76   # call Test::Builder::ok
77   my $ret = $tb->ok($same_bind, $msg);
78
79   # add debugging info
80   if (!$same_bind) {
81     _bind_differ_diag($bind_ref1, $bind_ref2);
82   }
83
84   # pass ok() result further
85   return $ret;
86 }
87
88 sub _sql_differ_diag {
89   my ($sql1, $sql2) = @_;
90
91   $tb->diag("SQL expressions differ\n"
92       ."     got: $sql1\n"
93       ."expected: $sql2\n"
94       ."differing in :\n$sql_differ\n"
95       );
96 }
97
98 sub _bind_differ_diag {
99   my ($bind_ref1, $bind_ref2) = @_;
100
101   $tb->diag("BIND values differ\n"
102       ."     got: " . Dumper($bind_ref1)
103       ."expected: " . Dumper($bind_ref2)
104       );
105 }
106
107 sub eq_sql_bind {
108   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
109
110   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
111 }
112
113
114 sub eq_bind {
115   my ($bind_ref1, $bind_ref2) = @_;
116
117   local $Data::Dumper::Useqq = 1;
118   local $Data::Dumper::Sortkeys = 1;
119
120   return Dumper($bind_ref1) eq Dumper($bind_ref2);
121 }
122
123 sub eq_sql {
124   my ($sql1, $sql2) = @_;
125
126   # parse
127   my $tree1 = $sqlat->parse($sql1);
128   my $tree2 = $sqlat->parse($sql2);
129
130   return 1 if _eq_sql($tree1, $tree2);
131 }
132
133 sub _eq_sql {
134   my ($left, $right) = @_;
135
136   # one is defined the other not
137   if ( (defined $left) xor (defined $right) ) {
138     return 0;
139   }
140   # one is undefined, then so is the other
141   elsif (not defined $left) {
142     return 1;
143   }
144   # one is a list, the other is an op with a list
145   elsif (ref $left->[0] xor ref $right->[0]) {
146     $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
147     return 0;
148   }
149   # one is a list, so is the other
150   elsif (ref $left->[0]) {
151     for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
152       return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
153     }
154     return 1;
155   }
156   # both are an op-list combo
157   else {
158
159     # unroll parenthesis if possible/allowed
160     _parenthesis_unroll ($_) for ($left, $right);
161
162     # if operators are different
163     if ( $left->[0] ne $right->[0] ) {
164       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
165         $sqlat->unparse($left),
166         $sqlat->unparse($right);
167       return 0;
168     }
169     # elsif operators are identical, compare operands
170     else {
171       if ($left->[0] eq 'LITERAL' ) { # unary
172         (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
173         (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
174         my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
175         $sql_differ = "[$l] != [$r]\n" if not $eq;
176         return $eq;
177       }
178       else {
179         my $eq = _eq_sql($left->[1], $right->[1]);
180         $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
181         return $eq;
182       }
183     }
184   }
185 }
186
187 sub _parenthesis_unroll {
188   my $ast = shift;
189
190   return if $parenthesis_significant;
191   return unless (ref $ast and ref $ast->[1]);
192
193   my $changes;
194   do {
195     my @children;
196     $changes = 0;
197
198     for my $child (@{$ast->[1]}) {
199       if (not ref $child or not $child->[0] eq 'PAREN') {
200         push @children, $child;
201         next;
202       }
203
204       # unroll nested parenthesis
205       while ($child->[1][0][0] eq 'PAREN') {
206         $child = $child->[1][0];
207         $changes++;
208       }
209
210       # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
211       if (
212         ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
213             and
214           $child->[1][0][0] eq $ast->[0]
215       ) {
216         push @children, @{$child->[1][0][1]};
217         $changes++;
218       }
219
220       # if the parent operator explcitly allows it nuke the parenthesis
221       elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
222         push @children, $child->[1][0];
223         $changes++;
224       }
225
226       # only one LITERAL element in the parenthesis
227       elsif (
228         @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
229       ) {
230         push @children, $child->[1][0];
231         $changes++;
232       }
233
234       # only one element in the parenthesis which is a binary op with two LITERAL sub-children
235       elsif (
236         @{$child->[1]} == 1
237           and
238         grep { $child->[1][0][0] =~ /^ $_ $/xi } (SQL::Abstract::Tree::_binary_op_keywords())
239           and
240         $child->[1][0][1][0][0] eq 'LITERAL'
241           and
242         $child->[1][0][1][1][0] eq 'LITERAL'
243       ) {
244         push @children, $child->[1][0];
245         $changes++;
246       }
247
248       # otherwise no more mucking for this pass
249       else {
250         push @children, $child;
251       }
252     }
253
254     $ast->[1] = \@children;
255
256   } while ($changes);
257
258 }
259
260 sub parse { $sqlat->parse(@_) }
261 1;
262
263
264 __END__
265
266 =head1 NAME
267
268 SQL::Abstract::Test - Helper function for testing SQL::Abstract
269
270 =head1 SYNOPSIS
271
272   use SQL::Abstract;
273   use Test::More;
274   use SQL::Abstract::Test import => [qw/
275     is_same_sql_bind is_same_sql is_same_bind
276     eq_sql_bind eq_sql eq_bind
277   /];
278
279   my ($sql, @bind) = SQL::Abstract->new->select(%args);
280
281   is_same_sql_bind($given_sql,    \@given_bind,
282                    $expected_sql, \@expected_bind, $test_msg);
283
284   is_same_sql($given_sql, $expected_sql, $test_msg);
285   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
286
287   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
288                             $expected_sql, \@expected_bind);
289
290   my $sql_same = eq_sql($given_sql, $expected_sql);
291   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
292
293 =head1 DESCRIPTION
294
295 This module is only intended for authors of tests on
296 L<SQL::Abstract|SQL::Abstract> and related modules;
297 it exports functions for comparing two SQL statements
298 and their bound values.
299
300 The SQL comparison is performed on I<abstract syntax>,
301 ignoring differences in spaces or in levels of parentheses.
302 Therefore the tests will pass as long as the semantics
303 is preserved, even if the surface syntax has changed.
304
305 B<Disclaimer> : the semantic equivalence handling is pretty limited.
306 A lot of effort goes into distinguishing significant from
307 non-significant parenthesis, including AND/OR operator associativity.
308 Currently this module does not support commutativity and more
309 intelligent transformations like Morgan laws, etc.
310
311 For a good overview of what this test framework is capable of refer
312 to C<t/10test.t>
313
314 =head1 FUNCTIONS
315
316 =head2 is_same_sql_bind
317
318   is_same_sql_bind($given_sql,    \@given_bind,
319                    $expected_sql, \@expected_bind, $test_msg);
320
321 Compares given and expected pairs of C<($sql, \@bind)>, and calls
322 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
323 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
324 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
325 L</is_same_bind>) that needs to be imported.
326
327 =head2 is_same_sql
328
329   is_same_sql($given_sql, $expected_sql, $test_msg);
330
331 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
332 the result, with C<$test_msg> as message. If the test fails, a detailed
333 diagnostic is printed. For clients which use L<Test::More>, this is the one of
334 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
335 that needs to be imported.
336
337 =head2 is_same_bind
338
339   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
340
341 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
342 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
343 is printed. For clients which use L<Test::More>, this is the one of the three
344 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
345 to be imported.
346
347 =head2 eq_sql_bind
348
349   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
350                             $expected_sql, \@expected_bind);
351
352 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
353 L</is_same_sql_bind>, but it just returns a boolean value and does not print
354 diagnostics or talk to L<Test::Builder>.
355
356 =head2 eq_sql
357
358   my $is_same = eq_sql($given_sql, $expected_sql);
359
360 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
361 but it just returns a boolean value and does not print diagnostics or talk to
362 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
363 will contain the SQL portion where a difference was encountered; this is useful
364 for printing diagnostics.
365
366 =head2 eq_bind
367
368   my $is_same = eq_sql(\@given_bind, \@expected_bind);
369
370 Compares two lists of bind values, taking into account the fact that some of
371 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
372 L</is_same_bind>, but it just returns a boolean value and does not print
373 diagnostics or talk to L<Test::Builder>.
374
375 =head1 GLOBAL VARIABLES
376
377 =head2 $case_sensitive
378
379 If true, SQL comparisons will be case-sensitive. Default is false;
380
381 =head2 $parenthesis_significant
382
383 If true, SQL comparison will preserve and report difference in nested
384 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
385
386 =head2 $sql_differ
387
388 When L</eq_sql> returns false, the global variable
389 C<$sql_differ> contains the SQL portion
390 where a difference was encountered.
391
392
393 =head1 SEE ALSO
394
395 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
396
397 =head1 AUTHORS
398
399 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
400
401 Norbert Buchmuller <norbi@nix.hu>
402
403 Peter Rabbitson <ribasushi@cpan.org>
404
405 =head1 COPYRIGHT AND LICENSE
406
407 Copyright 2008 by Laurent Dami.
408
409 This library is free software; you can redistribute it and/or modify
410 it under the same terms as Perl itself.