test is case insensitive, result should be lower cased
[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 Test::Builder;
7 use Test::Deep ();
8 use SQL::Abstract::Tree;
9
10 {
11   my $class;
12   if ($class = $ENV{SQL_ABSTRACT_TEST_AGAINST}) {
13     my $mod = join('/', split '::', $class).".pm";
14     require $mod;
15     eval qq{sub SQL::Abstract () { "\Q${class}\E" }; 1}
16       or die "Failed to create const sub for ${class}: $@";
17   }
18   if ($ENV{SQL_ABSTRACT_TEST_EXPAND_STABILITY}) {
19     $class ||= do { require SQL::Abstract; 'SQL::Abstract' };
20     my $orig = $class->can('expand_expr');
21     require Data::Dumper::Concise;
22     my $wrapped = sub {
23       my ($self, @args) = @_;
24       my $e1 = $self->$orig(@args);
25       return $e1 if our $Stab_Check_Rec;
26       local $Stab_Check_Rec = 1;
27       my $e2 = $self->$orig($e1);
28       my ($d1, $d2) = map Data::Dumper::Concise::Dumper($_), $e1, $e2;
29       (our $tb)->is_eq(
30         $d2, $d1,
31         'expand_expr stability ok'
32       ) or do {
33         require Path::Tiny;
34         Path::Tiny->new('e1')->spew($d1);
35         Path::Tiny->new('e2')->spew($d2);
36         system('diff -u e1 e2 1>&2');
37         die "Differences between e1 and e2, bailing out";
38       };
39       return $e1;
40     };
41     no strict 'refs'; no warnings 'redefine';
42     *{"${class}::expand_expr"} = $wrapped;
43   }
44 }
45
46 our @EXPORT_OK = qw(
47   is_same_sql_bind is_same_sql is_same_bind
48   eq_sql_bind eq_sql eq_bind dumper diag_where
49   $case_sensitive $sql_differ
50 );
51
52 my $sqlat = SQL::Abstract::Tree->new;
53
54 our $case_sensitive = 0;
55 our $parenthesis_significant = 0;
56 our $order_by_asc_significant = 0;
57
58 our $sql_differ; # keeps track of differing portion between SQLs
59 our $tb = __PACKAGE__->builder;
60
61 sub _unpack_arrayrefref {
62
63   my @args;
64   for (1,2) {
65     my $chunk = shift @_;
66
67     if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
68       my ($sql, @bind) = @$$chunk;
69       push @args, ($sql, \@bind);
70     }
71     else {
72       push @args, $chunk, shift @_;
73     }
74
75   }
76
77   # maybe $msg and ... stuff
78   push @args, @_;
79
80   @args;
81 }
82
83 sub is_same_sql_bind {
84   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref;
85
86   # compare
87   my $same_sql  = eq_sql($sql1, $sql2);
88   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
89
90   # call Test::Builder::ok
91   my $ret = $tb->ok($same_sql && $same_bind, $msg);
92
93   # add debugging info
94   if (!$same_sql) {
95     _sql_differ_diag($sql1, $sql2);
96   }
97   if (!$same_bind) {
98     _bind_differ_diag($bind_ref1, $bind_ref2);
99   }
100
101   # pass ok() result further
102   return $ret;
103 }
104
105 sub is_same_sql {
106   my ($sql1, $sql2, $msg) = @_;
107
108   # compare
109   my $same_sql = eq_sql($sql1, $sql2);
110
111   # call Test::Builder::ok
112   my $ret = $tb->ok($same_sql, $msg);
113
114   # add debugging info
115   if (!$same_sql) {
116     _sql_differ_diag($sql1, $sql2);
117   }
118
119   # pass ok() result further
120   return $ret;
121 }
122
123 sub is_same_bind {
124   my ($bind_ref1, $bind_ref2, $msg) = @_;
125
126   # compare
127   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
128
129   # call Test::Builder::ok
130   my $ret = $tb->ok($same_bind, $msg);
131
132   # add debugging info
133   if (!$same_bind) {
134     _bind_differ_diag($bind_ref1, $bind_ref2);
135   }
136
137   # pass ok() result further
138   return $ret;
139 }
140
141 sub dumper {
142   # FIXME
143   # if we save the instance, we will end up with $VARx references
144   # no time to figure out how to avoid this (Deepcopy is *not* an option)
145   require Data::Dumper;
146   Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
147     ->Values([@_])->Dump;
148 }
149
150 sub diag_where{
151   $tb->diag("Search term:\n" . &dumper);
152 }
153
154 sub _sql_differ_diag {
155   my $sql1 = shift || '';
156   my $sql2 = shift || '';
157
158   if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
159     my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
160     $_ = $sqlat->format($_) for ($sql1, $sql2);
161   }
162
163   $tb->${\($tb->in_todo ? 'note' : 'diag')} (
164        "SQL expressions differ\n"
165       ." got: $sql1\n"
166       ."want: $sql2\n"
167       ."\nmismatch around\n$sql_differ\n"
168   );
169 }
170
171 sub _bind_differ_diag {
172   my ($bind_ref1, $bind_ref2) = @_;
173
174   $tb->${\($tb->in_todo ? 'note' : 'diag')} (
175     "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
176   );
177 }
178
179 sub eq_sql_bind {
180   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
181
182   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
183 }
184
185
186 sub eq_bind { goto &Test::Deep::eq_deeply };
187
188 sub eq_sql {
189   my ($sql1, $sql2) = @_;
190
191   # parse
192   my $tree1 = $sqlat->parse($sql1);
193   my $tree2 = $sqlat->parse($sql2);
194
195   undef $sql_differ;
196   return 1 if _eq_sql($tree1, $tree2);
197 }
198
199 sub _eq_sql {
200   my ($left, $right) = @_;
201
202   # one is defined the other not
203   if ((defined $left) xor (defined $right)) {
204     $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
205     return 0;
206   }
207
208   # one is undefined, then so is the other
209   elsif (not defined $left) {
210     return 1;
211   }
212
213   # both are empty
214   elsif (@$left == 0 and @$right == 0) {
215     return 1;
216   }
217
218   # one is empty
219   if (@$left == 0 or @$right == 0) {
220     $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
221     return 0;
222   }
223
224   # one is a list, the other is an op with a list
225   elsif (ref $left->[0] xor ref $right->[0]) {
226     $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
227       { ref $_ ? $sqlat->unparse($_) : $_ }
228       ($left->[0], $right->[0], $left, $right)
229     );
230     return 0;
231   }
232
233   # both are lists
234   elsif (ref $left->[0]) {
235     for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
236       if (not _eq_sql ($left->[$i], $right->[$i]) ) {
237         if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
238           $sql_differ ||= '';
239           $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
240           $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
241         }
242         return 0;
243       }
244     }
245     return 1;
246   }
247
248   # both are ops
249   else {
250
251     # unroll parenthesis if possible/allowed
252     unless ($parenthesis_significant) {
253       $sqlat->_parenthesis_unroll($_) for $left, $right;
254     }
255
256     # unroll ASC order by's
257     unless ($order_by_asc_significant) {
258       $sqlat->_strip_asc_from_order_by($_) for $left, $right;
259     }
260
261     if ($left->[0] ne $right->[0]) {
262       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
263         $sqlat->unparse($left),
264         $sqlat->unparse($right)
265       ;
266       return 0;
267     }
268
269     # literals have a different arg-sig
270     elsif ($left->[0] eq '-LITERAL') {
271       (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
272       (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
273       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
274       $sql_differ = "[$l] != [$r]\n" if not $eq;
275       return $eq;
276     }
277
278     # if operators are identical, compare operands
279     else {
280       my $eq = _eq_sql($left->[1], $right->[1]);
281       $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
282       return $eq;
283     }
284   }
285 }
286
287 sub parse { $sqlat->parse(@_) }
288 1;
289
290
291 __END__
292
293 =head1 NAME
294
295 SQL::Abstract::Test - Helper function for testing SQL::Abstract
296
297 =head1 SYNOPSIS
298
299   use SQL::Abstract;
300   use Test::More;
301   use SQL::Abstract::Test import => [qw/
302     is_same_sql_bind is_same_sql is_same_bind
303     eq_sql_bind eq_sql eq_bind
304   /];
305
306   my ($sql, @bind) = SQL::Abstract->new->select(%args);
307
308   is_same_sql_bind($given_sql,    \@given_bind,
309                    $expected_sql, \@expected_bind, $test_msg);
310
311   is_same_sql($given_sql, $expected_sql, $test_msg);
312   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
313
314   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
315                             $expected_sql, \@expected_bind);
316
317   my $sql_same = eq_sql($given_sql, $expected_sql);
318   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
319
320 =head1 DESCRIPTION
321
322 This module is only intended for authors of tests on
323 L<SQL::Abstract|SQL::Abstract> and related modules;
324 it exports functions for comparing two SQL statements
325 and their bound values.
326
327 The SQL comparison is performed on I<abstract syntax>,
328 ignoring differences in spaces or in levels of parentheses.
329 Therefore the tests will pass as long as the semantics
330 is preserved, even if the surface syntax has changed.
331
332 B<Disclaimer> : the semantic equivalence handling is pretty limited.
333 A lot of effort goes into distinguishing significant from
334 non-significant parenthesis, including AND/OR operator associativity.
335 Currently this module does not support commutativity and more
336 intelligent transformations like L<De Morgan's laws
337 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
338
339 For a good overview of what this test framework is currently capable of refer
340 to C<t/10test.t>
341
342 =head1 FUNCTIONS
343
344 =head2 is_same_sql_bind
345
346   is_same_sql_bind(
347     $given_sql, \@given_bind,
348     $expected_sql, \@expected_bind,
349     $test_msg
350   );
351
352   is_same_sql_bind(
353     \[$given_sql, @given_bind],
354     \[$expected_sql, @expected_bind],
355     $test_msg
356   );
357
358   is_same_sql_bind(
359     $dbic_rs->as_query
360     $expected_sql, \@expected_bind,
361     $test_msg
362   );
363
364 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
365 as shown in the examples above and passing the arguments to L</eq_sql> and
366 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
367 C<$test_msg> as message.
368 If the test fails, a detailed diagnostic is printed.
369
370 =head2 is_same_sql
371
372   is_same_sql(
373     $given_sql,
374     $expected_sql,
375     $test_msg
376   );
377
378 Compares given and expected SQL statements via L</eq_sql>, and calls
379 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
380 If the test fails, a detailed diagnostic is printed.
381
382 =head2 is_same_bind
383
384   is_same_bind(
385     \@given_bind,
386     \@expected_bind,
387     $test_msg
388   );
389
390 Compares given and expected bind values via L</eq_bind>, and calls
391 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
392 If the test fails, a detailed diagnostic is printed.
393
394 =head2 eq_sql_bind
395
396   my $is_same = eq_sql_bind(
397     $given_sql, \@given_bind,
398     $expected_sql, \@expected_bind,
399   );
400
401   my $is_same = eq_sql_bind(
402     \[$given_sql, @given_bind],
403     \[$expected_sql, @expected_bind],
404   );
405
406   my $is_same = eq_sql_bind(
407     $dbic_rs->as_query
408     $expected_sql, \@expected_bind,
409   );
410
411 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
412 L</eq_bind>, returning their combined result.
413
414 =head2 eq_sql
415
416   my $is_same = eq_sql($given_sql, $expected_sql);
417
418 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
419 but it just returns a boolean value and does not print diagnostics or talk to
420 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
421 will contain the SQL portion where a difference was encountered; this is useful
422 for printing diagnostics.
423
424 =head2 eq_bind
425
426   my $is_same = eq_sql(\@given_bind, \@expected_bind);
427
428 Compares two lists of bind values, taking into account the fact that some of
429 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
430 L</is_same_bind>, but it just returns a boolean value and does not print
431 diagnostics or talk to L<Test::Builder>.
432
433 =head1 GLOBAL VARIABLES
434
435 =head2 $case_sensitive
436
437 If true, SQL comparisons will be case-sensitive. Default is false;
438
439 =head2 $parenthesis_significant
440
441 If true, SQL comparison will preserve and report difference in nested
442 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
443 Defaults to false;
444
445 =head2 $order_by_asc_significant
446
447 If true SQL comparison will consider C<ORDER BY foo ASC> and
448 C<ORDER BY foo> to be different. Default is false;
449
450 =head2 $sql_differ
451
452 When L</eq_sql> returns false, the global variable
453 C<$sql_differ> contains the SQL portion
454 where a difference was encountered.
455
456 =head1 SEE ALSO
457
458 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
459
460 =head1 AUTHORS
461
462 Laurent Dami <laurent.dami AT etat  geneve  ch>
463
464 Norbert Buchmuller <norbi@nix.hu>
465
466 Peter Rabbitson <ribasushi@cpan.org>
467
468 =head1 COPYRIGHT AND LICENSE
469
470 Copyright 2008 by Laurent Dami.
471
472 This library is free software; you can redistribute it and/or modify
473 it under the same terms as Perl itself.