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 use Test::Deep qw(eq_deeply);
12 our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind
13 $case_sensitive $sql_differ/;
15 our $case_sensitive = 0;
16 our $sql_differ; # keeps track of differing portion between SQLs
17 our $tb = __PACKAGE__->builder;
19 sub is_same_sql_bind {
20 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
23 my $tree1 = parse($sql1);
24 my $tree2 = parse($sql2);
25 my $same_sql = eq_sql($tree1, $tree2);
26 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
28 # call Test::Builder::ok
29 $tb->ok($same_sql && $same_bind, $msg);
33 $tb->diag("SQL expressions differ\n"
36 ."differing in :\n$sql_differ\n"
40 $tb->diag("BIND values differ\n"
41 ." got: " . Dumper($bind_ref1)
42 ."expected: " . Dumper($bind_ref2)
48 my ($bind_ref1, $bind_ref2) = @_;
50 return eq_deeply($bind_ref1, $bind_ref2);
54 my ($left, $right) = @_;
56 # ignore top-level parentheses
57 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
58 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
60 # if operators are different
61 if ($left->[0] ne $right->[0]) {
62 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
67 # elsif operators are identical, compare operands
69 if ($left->[0] eq 'EXPR' ) { # unary operator
70 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
71 (my $r = " $right->[1] ") =~ s/\s+/ /g;
72 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
73 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
76 else { # binary operator
77 return eq_sql($left->[1][0], $right->[1][0]) # left operand
78 && eq_sql($left->[1][1], $right->[1][1]); # right operand
88 my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];
90 my $tree = _recurse_parse($tokens);
98 while (1) { # left-associative parsing
100 my $lookahead = $tokens->[0];
101 return $left if !defined($lookahead) || $lookahead eq ')';
103 my $token = shift @$tokens;
105 # nested expression in ()
107 my $right = _recurse_parse($tokens);
108 $token = shift @$tokens or croak "missing ')'";
109 $token eq ')' or croak "unexpected token : $token";
110 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
114 elsif ($token eq 'AND' || $token eq 'OR') {
115 my $right = _recurse_parse($tokens);
116 $left = [$token => [$left, $right]];
120 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
131 EXPR => sub {$tree->[1] },
132 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
133 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
134 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
135 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
137 $dispatch->{$tree->[0]}->();
148 SQL::Abstract::Test - Helper function for testing SQL::Abstract
154 use SQL::Abstract::Test import => ['is_same_sql_bind'];
156 my ($sql, @bind) = SQL::Abstract->new->select(%args);
157 is_same_sql_bind($given_sql, \@given_bind,
158 $expected_sql, \@expected_bind, $test_msg);
162 This module is only intended for authors of tests on
163 L<SQL::Abstract|SQL::Abstract> and related modules;
164 it exports functions for comparing two SQL statements
165 and their bound values.
167 The SQL comparison is performed on I<abstract syntax>,
168 ignoring differences in spaces or in levels of parentheses.
169 Therefore the tests will pass as long as the semantics
170 is preserved, even if the surface syntax has changed.
172 B<Disclaimer> : this is only a half-cooked semantic equivalence;
173 parsing is simple-minded, and comparison of SQL abstract syntax trees
174 ignores commutativity or associativity of AND/OR operators, Morgan
179 =head2 is_same_sql_bind
181 is_same_sql_bind($given_sql, \@given_bind,
182 $expected_sql, \@expected_bind, $test_msg);
184 Compares given and expected pairs of C<($sql, \@bind)>, and calls
185 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
186 test fails, a detailed diagnostic is printed. For clients which use
187 L<Test::Build>, this is the only function that needs to be
192 my $is_same = eq_sql($given_sql, $expected_sql);
194 Compares the abstract syntax of two SQL statements. If the result is
195 false, global variable L</sql_differ> will contain the SQL portion
196 where a difference was encountered; this is useful for printing diagnostics.
200 my $is_same = eq_sql(\@given_bind, \@expected_bind);
202 Compares two lists of bind values, taking into account
203 the fact that some of the values may be
204 arrayrefs (see L<SQL::Abstract/bindtype>).
206 =head1 GLOBAL VARIABLES
208 =head2 case_sensitive
210 If true, SQL comparisons will be case-sensitive. Default is false;
214 When L</eq_sql> returns false, the global variable
215 C<$sql_differ> contains the SQL portion
216 where a difference was encountered.
221 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
225 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
227 =head1 COPYRIGHT AND LICENSE
229 Copyright 2008 by Laurent Dami.
231 This library is free software; you can redistribute it and/or modify
232 it under the same terms as Perl itself.