rename DBIC::Storage::PP and get ready to re-release
[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);
29
fffe6900 30sub is_same_sql_bind {
31 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
32
33 # compare
25823711 34 my $same_sql = eq_sql($sql1, $sql2);
fffe6900 35 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
36
a6daa642 37 # call Test::Builder::ok
1a828f61 38 my $ret = $tb->ok($same_sql && $same_bind, $msg);
fffe6900 39
40 # add debugging info
41 if (!$same_sql) {
e7827ba2 42 _sql_differ_diag($sql1, $sql2);
fffe6900 43 }
44 if (!$same_bind) {
e7827ba2 45 _bind_differ_diag($bind_ref1, $bind_ref2);
fffe6900 46 }
1a828f61 47
48 # pass ok() result further
49 return $ret;
fffe6900 50}
51
e7827ba2 52sub 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
1a828f61 59 my $ret = $tb->ok($same_sql, $msg);
e7827ba2 60
61 # add debugging info
62 if (!$same_sql) {
63 _sql_differ_diag($sql1, $sql2);
64 }
1a828f61 65
66 # pass ok() result further
67 return $ret;
e7827ba2 68}
69
70sub 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
1a828f61 77 my $ret = $tb->ok($same_bind, $msg);
e7827ba2 78
79 # add debugging info
80 if (!$same_bind) {
81 _bind_differ_diag($bind_ref1, $bind_ref2);
82 }
1a828f61 83
84 # pass ok() result further
85 return $ret;
e7827ba2 86}
87
88sub _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
98sub _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
107sub 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
fffe6900 114sub eq_bind {
115 my ($bind_ref1, $bind_ref2) = @_;
fffe6900 116
fdfbbc65 117 local $Data::Dumper::Useqq = 1;
118 local $Data::Dumper::Sortkeys = 1;
119
120 return Dumper($bind_ref1) eq Dumper($bind_ref2);
fffe6900 121}
122
123sub eq_sql {
25823711 124 my ($sql1, $sql2) = @_;
125
126 # parse
a24cc3a0 127 my $tree1 = $sqlat->parse($sql1);
128 my $tree2 = $sqlat->parse($sql2);
25823711 129
1b17d1b0 130 return 1 if _eq_sql($tree1, $tree2);
25823711 131}
132
133sub _eq_sql {
fffe6900 134 my ($left, $right) = @_;
135
939db550 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) {
d15c14cc 142 return 1;
143 }
1b17d1b0 144 # one is a list, the other is an op with a list
145 elsif (ref $left->[0] xor ref $right->[0]) {
a24cc3a0 146 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
fffe6900 147 return 0;
148 }
1b17d1b0 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
e40f5df9 159 # unroll parenthesis if possible/allowed
160 _parenthesis_unroll ($_) for ($left, $right);
1b17d1b0 161
162 # if operators are different
b9a4fdae 163 if ( $left->[0] ne $right->[0] ) {
1b17d1b0 164 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
a24cc3a0 165 $sqlat->unparse($left),
166 $sqlat->unparse($right);
1b17d1b0 167 return 0;
168 }
169 # elsif operators are identical, compare operands
01dd4e4f 170 else {
b9a4fdae 171 if ($left->[0] eq 'LITERAL' ) { # unary
01b64cb7 172 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
173 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
1b17d1b0 174 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
01b64cb7 175 $sql_differ = "[$l] != [$r]\n" if not $eq;
1b17d1b0 176 return $eq;
177 }
178 else {
179 my $eq = _eq_sql($left->[1], $right->[1]);
a24cc3a0 180 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
1b17d1b0 181 return $eq;
182 }
fffe6900 183 }
184 }
185}
186
e40f5df9 187sub _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 }
fffe6900 219
e40f5df9 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
b9a4fdae 226 # only one LITERAL element in the parenthesis
9e8dab3f 227 elsif (
b9a4fdae 228 @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
9e8dab3f 229 ) {
230 push @children, $child->[1][0];
231 $changes++;
232 }
233
b9a4fdae 234 # only one element in the parenthesis which is a binary op with two LITERAL sub-children
e40f5df9 235 elsif (
236 @{$child->[1]} == 1
237 and
01dd4e4f 238 grep { $child->[1][0][0] =~ /^ $_ $/xi } (SQL::Abstract::Tree::_binary_op_keywords())
e40f5df9 239 and
b9a4fdae 240 $child->[1][0][1][0][0] eq 'LITERAL'
e40f5df9 241 and
b9a4fdae 242 $child->[1][0][1][1][0] eq 'LITERAL'
e40f5df9 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}
fffe6900 259
7853a177 260sub parse { $sqlat->parse(@_) }
fffe6900 2611;
262
263
264__END__
265
266=head1 NAME
267
268SQL::Abstract::Test - Helper function for testing SQL::Abstract
269
270=head1 SYNOPSIS
271
272 use SQL::Abstract;
273 use Test::More;
e7827ba2 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 /];
ec9af79e 278
fffe6900 279 my ($sql, @bind) = SQL::Abstract->new->select(%args);
e7827ba2 280
01dd4e4f 281 is_same_sql_bind($given_sql, \@given_bind,
fffe6900 282 $expected_sql, \@expected_bind, $test_msg);
283
e7827ba2 284 is_same_sql($given_sql, $expected_sql, $test_msg);
285 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
286
01dd4e4f 287 my $is_same = eq_sql_bind($given_sql, \@given_bind,
e7827ba2 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
fffe6900 293=head1 DESCRIPTION
294
295This module is only intended for authors of tests on
296L<SQL::Abstract|SQL::Abstract> and related modules;
297it exports functions for comparing two SQL statements
298and their bound values.
299
300The SQL comparison is performed on I<abstract syntax>,
301ignoring differences in spaces or in levels of parentheses.
302Therefore the tests will pass as long as the semantics
303is preserved, even if the surface syntax has changed.
304
ec9af79e 305B<Disclaimer> : the semantic equivalence handling is pretty limited.
306A lot of effort goes into distinguishing significant from
307non-significant parenthesis, including AND/OR operator associativity.
308Currently this module does not support commutativity and more
309intelligent transformations like Morgan laws, etc.
310
01dd4e4f 311For a good overview of what this test framework is capable of refer
ec9af79e 312to C<t/10test.t>
fffe6900 313
314=head1 FUNCTIONS
315
316=head2 is_same_sql_bind
317
01dd4e4f 318 is_same_sql_bind($given_sql, \@given_bind,
fffe6900 319 $expected_sql, \@expected_bind, $test_msg);
320
321Compares given and expected pairs of C<($sql, \@bind)>, and calls
e7827ba2 322L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
323fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
324this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
325L</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
331Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
332the result, with C<$test_msg> as message. If the test fails, a detailed
333diagnostic is printed. For clients which use L<Test::More>, this is the one of
334the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
335that needs to be imported.
336
337=head2 is_same_bind
338
339 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
340
341Compares given and expected bind values, and calls L<Test::Builder/ok> on the
342result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
343is printed. For clients which use L<Test::More>, this is the one of the three
344functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
345to be imported.
346
347=head2 eq_sql_bind
348
01dd4e4f 349 my $is_same = eq_sql_bind($given_sql, \@given_bind,
e7827ba2 350 $expected_sql, \@expected_bind);
351
352Compares given and expected pairs of C<($sql, \@bind)>. Similar to
353L</is_same_sql_bind>, but it just returns a boolean value and does not print
354diagnostics or talk to L<Test::Builder>.
fffe6900 355
356=head2 eq_sql
357
358 my $is_same = eq_sql($given_sql, $expected_sql);
359
e7827ba2 360Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
361but it just returns a boolean value and does not print diagnostics or talk to
362L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
363will contain the SQL portion where a difference was encountered; this is useful
364for printing diagnostics.
fffe6900 365
366=head2 eq_bind
367
368 my $is_same = eq_sql(\@given_bind, \@expected_bind);
369
e7827ba2 370Compares two lists of bind values, taking into account the fact that some of
371the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
372L</is_same_bind>, but it just returns a boolean value and does not print
373diagnostics or talk to L<Test::Builder>.
fffe6900 374
375=head1 GLOBAL VARIABLES
376
e7827ba2 377=head2 $case_sensitive
fffe6900 378
379If true, SQL comparisons will be case-sensitive. Default is false;
380
e40f5df9 381=head2 $parenthesis_significant
382
383If true, SQL comparison will preserve and report difference in nested
384parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
385
e7827ba2 386=head2 $sql_differ
fffe6900 387
388When L</eq_sql> returns false, the global variable
389C<$sql_differ> contains the SQL portion
390where a difference was encountered.
391
392
393=head1 SEE ALSO
394
a6daa642 395L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
fffe6900 396
25823711 397=head1 AUTHORS
fffe6900 398
399Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
400
25823711 401Norbert Buchmuller <norbi@nix.hu>
402
e96c510a 403Peter Rabbitson <ribasushi@cpan.org>
404
fffe6900 405=head1 COPYRIGHT AND LICENSE
406
407Copyright 2008 by Laurent Dami.
408
409This library is free software; you can redistribute it and/or modify
01dd4e4f 410it under the same terms as Perl itself.