1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
6 use Scalar::Util qw(looks_like_number blessed reftype);
10 our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind
11 $case_sensitive $sql_differ/;
13 our $case_sensitive = 0;
14 our $sql_differ; # keeps track of differing portion between SQLs
15 our $tb = __PACKAGE__->builder;
17 sub is_same_sql_bind {
18 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
21 my $tree1 = parse($sql1);
22 my $tree2 = parse($sql2);
23 my $same_sql = eq_sql($tree1, $tree2);
24 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
26 # call Test::Builder::ok
27 $tb->ok($same_sql && $same_bind, $msg);
31 $tb->diag("SQL expressions differ\n"
34 ."differing in :\n$sql_differ\n"
38 $tb->diag("BIND values differ\n"
39 ." got: " . Dumper($bind_ref1)
40 ."expected: " . Dumper($bind_ref2)
46 my ($bind_ref1, $bind_ref2) = @_;
48 my $ref1 = ref $bind_ref1;
49 my $ref2 = ref $bind_ref2;
51 return 0 if $ref1 ne $ref2;
53 if ($ref1 eq 'SCALAR' || $ref1 eq 'REF') {
54 return eq_bind($$bind_ref1, $$bind_ref2);
55 } elsif ($ref1 eq 'ARRAY') {
56 return 0 if scalar @$bind_ref1 != scalar @$bind_ref2;
57 for (my $i = 0; $i < @$bind_ref1; $i++) {
58 return 0 if !eq_bind($bind_ref1->[$i], $bind_ref2->[$i]);
61 } elsif ($ref1 eq 'HASH') {
64 [sort keys %$bind_ref1],
65 [sort keys %$bind_ref2]
68 [map { $bind_ref1->{$_} } sort keys %$bind_ref1],
69 [map { $bind_ref2->{$_} } sort keys %$bind_ref2]
72 if (!defined $bind_ref1 || !defined $bind_ref2) {
73 return !(defined $bind_ref1 ^ defined $bind_ref2);
74 } elsif (blessed($bind_ref1) || blessed($bind_ref2)) {
75 return 0 if (blessed($bind_ref1) || "") ne (blessed($bind_ref2) || "");
76 return 1 if $bind_ref1 == $bind_ref2; # uses overloaded '=='
77 # fallback: compare the guts of the object
78 my $reftype1 = reftype $bind_ref1;
79 my $reftype2 = reftype $bind_ref2;
80 return 0 if $reftype1 ne $reftype2;
81 if ($reftype1 eq 'SCALAR' || $reftype1 eq 'REF') {
82 $bind_ref1 = $$bind_ref1;
83 $bind_ref2 = $$bind_ref2;
84 } elsif ($reftype1 eq 'ARRAY') {
85 $bind_ref1 = [@$bind_ref1];
86 $bind_ref2 = [@$bind_ref2];
87 } elsif ($reftype1 eq 'HASH') {
88 $bind_ref1 = {%$bind_ref1};
89 $bind_ref2 = {%$bind_ref2};
93 return eq_bind($bind_ref1, $bind_ref2);
94 } elsif (looks_like_number($bind_ref1) && looks_like_number($bind_ref2)) {
95 return $bind_ref1 == $bind_ref2;
97 return $bind_ref1 eq $bind_ref2;
103 my ($left, $right) = @_;
105 # ignore top-level parentheses
106 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
107 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
109 # if operators are different
110 if ($left->[0] ne $right->[0]) {
111 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
116 # elsif operators are identical, compare operands
118 if ($left->[0] eq 'EXPR' ) { # unary operator
119 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
120 (my $r = " $right->[1] ") =~ s/\s+/ /g;
121 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
122 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
125 else { # binary operator
126 return eq_sql($left->[1][0], $right->[1][0]) # left operand
127 && eq_sql($left->[1][1], $right->[1][1]); # right operand
137 my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];
139 my $tree = _recurse_parse($tokens);
147 while (1) { # left-associative parsing
149 my $lookahead = $tokens->[0];
150 return $left if !defined($lookahead) || $lookahead eq ')';
152 my $token = shift @$tokens;
154 # nested expression in ()
156 my $right = _recurse_parse($tokens);
157 $token = shift @$tokens or croak "missing ')'";
158 $token eq ')' or croak "unexpected token : $token";
159 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
163 elsif ($token eq 'AND' || $token eq 'OR') {
164 my $right = _recurse_parse($tokens);
165 $left = [$token => [$left, $right]];
169 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
180 EXPR => sub {$tree->[1] },
181 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
182 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
183 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
184 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
186 $dispatch->{$tree->[0]}->();
197 SQL::Abstract::Test - Helper function for testing SQL::Abstract
203 use SQL::Abstract::Test import => ['is_same_sql_bind'];
205 my ($sql, @bind) = SQL::Abstract->new->select(%args);
206 is_same_sql_bind($given_sql, \@given_bind,
207 $expected_sql, \@expected_bind, $test_msg);
211 This module is only intended for authors of tests on
212 L<SQL::Abstract|SQL::Abstract> and related modules;
213 it exports functions for comparing two SQL statements
214 and their bound values.
216 The SQL comparison is performed on I<abstract syntax>,
217 ignoring differences in spaces or in levels of parentheses.
218 Therefore the tests will pass as long as the semantics
219 is preserved, even if the surface syntax has changed.
221 B<Disclaimer> : this is only a half-cooked semantic equivalence;
222 parsing is simple-minded, and comparison of SQL abstract syntax trees
223 ignores commutativity or associativity of AND/OR operators, Morgan
228 =head2 is_same_sql_bind
230 is_same_sql_bind($given_sql, \@given_bind,
231 $expected_sql, \@expected_bind, $test_msg);
233 Compares given and expected pairs of C<($sql, \@bind)>, and calls
234 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
235 test fails, a detailed diagnostic is printed. For clients which use
236 L<Test::Build>, this is the only function that needs to be
241 my $is_same = eq_sql($given_sql, $expected_sql);
243 Compares the abstract syntax of two SQL statements. If the result is
244 false, global variable L</sql_differ> will contain the SQL portion
245 where a difference was encountered; this is useful for printing diagnostics.
249 my $is_same = eq_sql(\@given_bind, \@expected_bind);
251 Compares two lists of bind values, taking into account
252 the fact that some of the values may be
253 arrayrefs (see L<SQL::Abstract/bindtype>).
255 =head1 GLOBAL VARIABLES
257 =head2 case_sensitive
259 If true, SQL comparisons will be case-sensitive. Default is false;
263 When L</eq_sql> returns false, the global variable
264 C<$sql_differ> contains the SQL portion
265 where a difference was encountered.
270 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
274 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
276 =head1 COPYRIGHT AND LICENSE
278 Copyright 2008 by Laurent Dami.
280 This library is free software; you can redistribute it and/or modify
281 it under the same terms as Perl itself.